6 module Data.Collections.Newtype.TH
10 import Control.Applicative hiding (empty)
11 import Control.Monad.Unicode
12 import Data.Collections
13 import Data.Collections.BaseInstances ()
15 import Data.Generics.Aliases
16 import Data.Generics.Schemes
18 import Language.Haskell.TH.Lib
19 import Language.Haskell.TH.Ppr
20 import Language.Haskell.TH.Syntax
21 import Prelude hiding ( concat, concatMap, exp, filter
22 , foldl, foldr, foldl1, foldr1, null)
23 import Prelude.Unicode
25 type Deriver = Q Cxt → Q Type → Q Exp → Q Exp → Q Dec
28 derive ∷ Q [Dec] → Q [Dec]
29 derive = (concat <$>) ∘ (mapM go =≪)
32 go (InstanceD c ty _) = deriveInstance c ty
33 go _ = fail "derive: usage: derive [d| instance A; instance B; ... |]"
35 deriveInstance ∷ Cxt → Type → Q [Dec]
37 = do (wrapperTy, deriver) ← inspectInstance ty
38 (wrap , wrapD ) ← genWrap wrapperTy
39 (unwrap , unwrapD) ← genUnwrap wrapperTy
40 instanceDecl ← deriver (return c )
44 return $ [ d | d ← wrapD , wrap `isUsedIn` instanceDecl ]
45 ⧺ [ d | d ← unwrapD, unwrap `isUsedIn` instanceDecl ]
48 isUsedIn ∷ (Eq α, Typeable α, Data β) ⇒ α → β → Bool
49 isUsedIn α = (> 0) ∘ gcount (mkQ False (≡ α))
51 inspectInstance ∷ Type → Q (Type, Deriver)
52 inspectInstance (AppT (AppT (ConT classTy) wrapperTy) _)
53 | classTy ≡ ''Unfoldable
54 = return (wrapperTy, deriveUnfoldable)
55 | classTy ≡ ''Foldable
56 = return (wrapperTy, deriveFoldable)
57 | classTy ≡ ''Collection
58 = return (wrapperTy, deriveCollection)
59 inspectInstance (AppT (AppT (AppT (ConT classTy) wrapperTy) _) _)
61 = return (wrapperTy, deriveIndexed)
63 = fail $ "deriveInstance: unsupported type: " ⧺ pprint ty
65 genWrap ∷ Type → Q (Exp, [Dec])
67 = do name ← newName "wrap"
68 (con, ty) ← wrapperConTy wrapperTy
70 [ sigD name [t| $(return ty) → $(return wrapperTy) |]
71 , pragInlD name (inlineSpecNoPhase True True)
72 , funD name [clause [] (normalB (conE con)) []]
74 return (VarE name, decls)
76 genUnwrap ∷ Type → Q (Exp, [Dec])
78 = do name ← newName "unwrap"
80 (con, ty) ← wrapperConTy wrapperTy
82 [ sigD name [t| $(return wrapperTy) → $(return ty) |]
83 , pragInlD name (inlineSpecNoPhase True True)
84 , funD name [clause [conP con [varP i]] (normalB (varE i)) []]
86 return (VarE name, decls)
88 wrapperConTy ∷ Type → Q (Name, Type)
89 wrapperConTy = (conTy =≪) ∘ tyInfo
91 tyInfo ∷ Type → Q Info
92 tyInfo (ConT name) = reify name
93 tyInfo (AppT ty _) = tyInfo ty
94 tyInfo (SigT ty _) = tyInfo ty
96 = fail $ "wrapperConTy: unsupported type: " ⧺ pprint ty
98 conTy ∷ Info → Q (Name, Type)
99 conTy (TyConI (NewtypeD [] _ [] (NormalC con [(NotStrict, ty)]) []))
102 = fail $ "wrapperConTy: unsupported type: " ⧺ pprint info
104 methodNames ∷ Name → Q [Name]
105 methodNames = (names =≪) ∘ reify
107 names ∷ Info → Q [Name]
108 names (ClassI (ClassD _ _ _ _ decls) _)
109 = return ∘ catMaybes $ map name decls
110 names c = fail $ "methodNames: not a class: " ⧺ pprint c
112 name ∷ Dec → Maybe Name
113 name (SigD n _) = Just n
116 pointfreeMethod ∷ (Name → Q Exp) → Name → [Q Dec]
117 pointfreeMethod f name
118 = [ funD name [clause [] (normalB (f name)) []]
119 -- THINKME: Inserting PragmaD in an InstanceD causes an error
120 -- least GHC 7.0.3. Why?
121 -- , pragInlD name (inlineSpecNoPhase True False)
124 deriveUnfoldable ∷ Q Cxt → Q Type → Q Exp → Q Exp → Q Dec
125 deriveUnfoldable c ty wrap unwrap
126 = do names ← methodNames ''Unfoldable
127 instanceD c ty $ concatMap (pointfreeMethod exp) names
132 = [| ($wrap ∘) ∘ (∘ $unwrap) ∘ insert |]
136 = [| $wrap ∘ singleton |]
138 = [| ($wrap ∘) ∘ (∘ $unwrap) ∘ insertMany |]
139 | name ≡ 'insertManySorted
140 = [| ($wrap ∘) ∘ (∘ $unwrap) ∘ insertManySorted |]
142 = fail $ "deriveUnfoldable: unknown method: " ⧺ pprint name
144 deriveFoldable ∷ Q Cxt → Q Type → Q Exp → Q Exp → Q Dec
145 deriveFoldable c ty _ unwrap
146 = do names ← methodNames ''Foldable
147 instanceD c ty $ concatMap (pointfreeMethod exp) names
152 = [| fold ∘ $unwrap |]
154 = [| (∘ $unwrap) ∘ foldMap |]
156 = [| flip flip $unwrap ∘ ((∘) ∘) ∘ foldr |]
158 = [| flip flip $unwrap ∘ ((∘) ∘) ∘ foldl |]
160 = [| (∘ $unwrap) ∘ foldr1 |]
162 = [| (∘ $unwrap) ∘ foldl1 |]
164 = [| null ∘ $unwrap |]
166 = [| size ∘ $unwrap |]
167 | name ≡ 'isSingleton
168 = [| isSingleton ∘ $unwrap |]
170 = fail $ "deriveFoldable: unknown method: " ⧺ pprint name
172 deriveCollection ∷ Q Cxt → Q Type → Q Exp → Q Exp → Q Dec
173 deriveCollection c ty wrap unwrap
174 = do names ← methodNames ''Collection
175 instanceD c ty $ concatMap (pointfreeMethod exp) names
180 = [| ($wrap ∘) ∘ (∘ $unwrap) ∘ filter |]
182 = fail $ "deriveCollection: unknown method: " ⧺ pprint name
184 deriveIndexed ∷ Q Cxt → Q Type → Q Exp → Q Exp → Q Dec
185 deriveIndexed c ty wrap unwrap
186 = do names ← methodNames ''Indexed
187 instanceD c ty $ concatMap (pointfreeMethod exp) names
192 = [| (∘ $unwrap) ∘ index |]
194 = [| (($wrap ∘) ∘) ∘ flip flip $unwrap ∘ ((∘) ∘) ∘ adjust |]
196 = [| (∘ $unwrap) ∘ inDomain |]
198 = [| ($wrap ∘) ∘ (//) ∘ $unwrap |]
200 = [| (($wrap ∘) ∘) ∘ (∘ $unwrap) ∘ accum |]
202 = fail $ "deriveIndexed: unknown method: " ⧺ pprint name