TemplateHaskell
, UnicodeSyntax
#-}
--- |FIXME: doc
+-- |Doesn't anyone know why these instances can't be derived using
+-- GeneralizedNewtypeDeriving? I think its limitation isn't reasonable
+-- at all...
module Data.Collections.Newtype.TH
( derive
)
where
import Control.Applicative hiding (empty)
+import Control.Arrow
import Control.Monad.Unicode
import Data.Collections
import Data.Collections.BaseInstances ()
import Language.Haskell.TH.Lib
import Language.Haskell.TH.Ppr
import Language.Haskell.TH.Syntax
-import Prelude hiding ( concat, concatMap, exp
- , foldl, foldr, foldl1, foldr1, null)
+import Prelude hiding ( concat, concatMap, exp, filter
+ , foldl, foldr, foldl1, foldr1
+ , lookup, null
+ )
import Prelude.Unicode
type Deriver = Q Cxt → Q Type → Q Exp → Q Exp → Q Dec
--- |FIXME: doc
+-- |Automatic newtype instance deriver for type classes defined by the
+-- collections-api package.
+--
+-- @
+-- {-\# LANGUAGE TemplateHaskell \#-}
+-- module Foo (T) where
+-- import "Data.Collections"
+-- import "Data.Collections.BaseInstances" ()
+-- import qualified Data.Collections.Newtype.TH as C
+-- import qualified "Data.Map" as M
+--
+-- newtype T = T (M.Map 'Int' 'Bool')
+--
+-- C.derive [d| instance 'Unfoldable' T ('Int', 'Bool')
+-- instance 'Foldable' T ('Int', 'Bool')
+-- instance 'Indexed' T 'Int' 'Bool'
+-- ...
+-- |]
+-- @
+--
+-- This function can derive the following instances:
+--
+-- * 'Unfoldable'
+--
+-- * 'Foldable'
+--
+-- * 'Collection'
+--
+-- * 'Indexed'
+--
+-- * 'Map'
+--
+-- * 'Set'
+--
+-- * 'SortingCollection'
+--
derive ∷ Q [Dec] → Q [Dec]
derive = (concat <$>) ∘ (mapM go =≪)
where
= return (wrapperTy, deriveUnfoldable)
| classTy ≡ ''Foldable
= return (wrapperTy, deriveFoldable)
+ | classTy ≡ ''Collection
+ = return (wrapperTy, deriveCollection)
+ | classTy ≡ ''Set
+ = return (wrapperTy, deriveSet)
+ | classTy ≡ ''SortingCollection
+ = return (wrapperTy, deriveSortingCollection)
+inspectInstance (AppT (AppT (AppT (ConT classTy) wrapperTy) _) _)
+ | classTy ≡ ''Indexed
+ = return (wrapperTy, deriveIndexed)
+ | classTy ≡ ''Map
+ = return (wrapperTy, deriveMap)
inspectInstance ty
= fail $ "deriveInstance: unsupported type: " ⧺ pprint ty
= [| isSingleton ∘ $unwrap |]
| otherwise
= fail $ "deriveFoldable: unknown method: " ⧺ pprint name
+
+deriveCollection ∷ Q Cxt → Q Type → Q Exp → Q Exp → Q Dec
+deriveCollection c ty wrap unwrap
+ = do names ← methodNames ''Collection
+ instanceD c ty $ concatMap (pointfreeMethod exp) names
+ where
+ exp ∷ Name → Q Exp
+ exp name
+ | name ≡ 'filter
+ = [| ($wrap ∘) ∘ (∘ $unwrap) ∘ filter |]
+ | otherwise
+ = fail $ "deriveCollection: unknown method: " ⧺ pprint name
+
+deriveIndexed ∷ Q Cxt → Q Type → Q Exp → Q Exp → Q Dec
+deriveIndexed c ty wrap unwrap
+ = do names ← methodNames ''Indexed
+ instanceD c ty $ concatMap (pointfreeMethod exp) names
+ where
+ exp ∷ Name → Q Exp
+ exp name
+ | name ≡ 'index
+ = [| (∘ $unwrap) ∘ index |]
+ | name ≡ 'adjust
+ = [| (($wrap ∘) ∘) ∘ flip flip $unwrap ∘ ((∘) ∘) ∘ adjust |]
+ | name ≡ 'inDomain
+ = [| (∘ $unwrap) ∘ inDomain |]
+ | name ≡ '(//)
+ = [| ($wrap ∘) ∘ (//) ∘ $unwrap |]
+ | name ≡ 'accum
+ = [| (($wrap ∘) ∘) ∘ (∘ $unwrap) ∘ accum |]
+ | otherwise
+ = fail $ "deriveIndexed: unknown method: " ⧺ pprint name
+
+deriveMap ∷ Q Cxt → Q Type → Q Exp → Q Exp → Q Dec
+deriveMap c ty wrap unwrap
+ = do names ← methodNames ''Map
+ instanceD c ty $ concatMap (pointfreeMethod exp) names
+ where
+ exp ∷ Name → Q Exp
+ exp name
+ | name ≡ 'delete
+ = [| ($wrap ∘) ∘ (∘ $unwrap) ∘ delete |]
+ | name ≡ 'member
+ = [| (∘ $unwrap) ∘ member |]
+ | name ≡ 'union
+ = [| ($wrap ∘) ∘ (∘ $unwrap) ∘ union ∘ $unwrap |]
+ | name ≡ 'intersection
+ = [| ($wrap ∘) ∘ (∘ $unwrap) ∘ intersection ∘ $unwrap |]
+ | name ≡ 'difference
+ = [| ($wrap ∘) ∘ (∘ $unwrap) ∘ difference ∘ $unwrap |]
+ | name ≡ 'isSubset
+ = [| (∘ $unwrap) ∘ isSubset ∘ $unwrap |]
+ | name ≡ 'isProperSubset
+ = [| (∘ $unwrap) ∘ isProperSubset ∘ $unwrap |]
+ | name ≡ 'lookup
+ = [| (∘ $unwrap) ∘ lookup |]
+ | name ≡ 'alter
+ = [| (($wrap ∘) ∘) ∘ flip flip $unwrap ∘ ((∘) ∘) ∘ alter |]
+ | name ≡ 'insertWith
+ = [| ((($wrap ∘) ∘) ∘) ∘ flip flip $unwrap ∘ ((flip ∘ ((∘) ∘)) ∘) ∘ insertWith |]
+ | name ≡ 'fromFoldableWith
+ = [| ($wrap ∘) ∘ fromFoldableWith |]
+ | name ≡ 'foldGroups
+ = [| (($wrap ∘) ∘) ∘ foldGroups |]
+ | name ≡ 'mapWithKey
+ = [| ($wrap ∘) ∘ (∘ $unwrap) ∘ mapWithKey |]
+ | name ≡ 'unionWith
+ = [| (($wrap ∘) ∘) ∘ flip flip $unwrap ∘ ((∘) ∘) ∘ (∘ $unwrap) ∘ unionWith |]
+ | name ≡ 'intersectionWith
+ = [| (($wrap ∘) ∘) ∘ flip flip $unwrap ∘ ((∘) ∘) ∘ (∘ $unwrap) ∘ intersectionWith |]
+ | name ≡ 'differenceWith
+ = [| (($wrap ∘) ∘) ∘ flip flip $unwrap ∘ ((∘) ∘) ∘ (∘ $unwrap) ∘ differenceWith |]
+ | name ≡ 'isSubmapBy
+ = [| flip flip $unwrap ∘ ((∘) ∘) ∘ (∘ $unwrap) ∘ isSubmapBy |]
+ | name ≡ 'isProperSubmapBy
+ = [| flip flip $unwrap ∘ ((∘) ∘) ∘ (∘ $unwrap) ∘ isProperSubmapBy |]
+ | otherwise
+ = fail $ "deriveMap: unknown method: " ⧺ pprint name
+
+deriveSet ∷ Q Cxt → Q Type → Q Exp → Q Exp → Q Dec
+deriveSet c ty _ _
+ = do names ← methodNames ''Set
+ instanceD c ty $ concatMap (pointfreeMethod exp) names
+ where
+ exp ∷ Name → Q Exp
+ exp name
+ | name ≡ 'haddock_candy
+ = [| haddock_candy |]
+ | otherwise
+ = fail $ "deriveSet: unknown method: " ⧺ pprint name
+
+deriveSortingCollection ∷ Q Cxt → Q Type → Q Exp → Q Exp → Q Dec
+deriveSortingCollection c ty wrap unwrap
+ = do names ← methodNames ''SortingCollection
+ instanceD c ty $ concatMap (pointfreeMethod exp) names
+ where
+ exp ∷ Name → Q Exp
+ exp name
+ | name ≡ 'minView
+ = [| (second $wrap <$>) ∘ minView ∘ $unwrap |]
+ | otherwise
+ = fail $ "deriveSortingCollection: unknown method: " ⧺ pprint name