5 -- |Doesn't anyone know why these instances can't be derived using
6 -- GeneralizedNewtypeDeriving? I think its limitation isn't reasonable
8 module Data.Collections.Newtype.TH
12 import Control.Applicative hiding (empty)
14 import Control.Monad.Unicode
15 import Data.Collections
16 import Data.Collections.BaseInstances ()
18 import Data.Generics.Aliases
19 import Data.Generics.Schemes
21 import Language.Haskell.TH.Lib
22 import Language.Haskell.TH.Ppr
23 import Language.Haskell.TH.Syntax
24 import Prelude hiding ( concat, concatMap, exp, filter
25 , foldl, foldr, foldl1, foldr1
28 import Prelude.Unicode
30 type Deriver = Q Cxt → Q Type → Q Exp → Q Exp → Q Dec
32 -- |Automatic newtype instance deriver for type classes defined by the
33 -- collections-api package.
36 -- {-\# LANGUAGE TemplateHaskell \#-}
37 -- module Foo (T) where
38 -- import "Data.Collections"
39 -- import "Data.Collections.BaseInstances" ()
40 -- import qualified Data.Collections.Newtype.TH as C
41 -- import qualified "Data.Map" as M
43 -- newtype T = T (M.Map 'Int' 'Bool')
45 -- C.derive [d| instance 'Unfoldable' T ('Int', 'Bool')
46 -- instance 'Foldable' T ('Int', 'Bool')
47 -- instance 'Indexed' T 'Int' 'Bool'
52 -- This function can derive the following instances:
66 -- * 'SortingCollection'
68 derive ∷ Q [Dec] → Q [Dec]
69 derive = (concat <$>) ∘ (mapM go =≪)
72 go (InstanceD c ty _) = deriveInstance c ty
73 go _ = fail "derive: usage: derive [d| instance A; instance B; ... |]"
75 deriveInstance ∷ Cxt → Type → Q [Dec]
77 = do (wrapperTy, deriver) ← inspectInstance ty
78 (wrap , wrapD ) ← genWrap wrapperTy
79 (unwrap , unwrapD) ← genUnwrap wrapperTy
80 instanceDecl ← deriver (return c )
84 return $ [ d | d ← wrapD , wrap `isUsedIn` instanceDecl ]
85 ⧺ [ d | d ← unwrapD, unwrap `isUsedIn` instanceDecl ]
88 isUsedIn ∷ (Eq α, Typeable α, Data β) ⇒ α → β → Bool
89 isUsedIn α = (> 0) ∘ gcount (mkQ False (≡ α))
91 inspectInstance ∷ Type → Q (Type, Deriver)
92 inspectInstance (AppT (AppT (ConT classTy) wrapperTy) _)
93 | classTy ≡ ''Unfoldable
94 = return (wrapperTy, deriveUnfoldable)
95 | classTy ≡ ''Foldable
96 = return (wrapperTy, deriveFoldable)
97 | classTy ≡ ''Collection
98 = return (wrapperTy, deriveCollection)
100 = return (wrapperTy, deriveSet)
101 | classTy ≡ ''SortingCollection
102 = return (wrapperTy, deriveSortingCollection)
103 inspectInstance (AppT (AppT (AppT (ConT classTy) wrapperTy) _) _)
104 | classTy ≡ ''Indexed
105 = return (wrapperTy, deriveIndexed)
107 = return (wrapperTy, deriveMap)
109 = fail $ "deriveInstance: unsupported type: " ⧺ pprint ty
111 genWrap ∷ Type → Q (Exp, [Dec])
113 = do name ← newName "wrap"
114 (con, ty) ← wrapperConTy wrapperTy
116 [ sigD name [t| $(return ty) → $(return wrapperTy) |]
117 , pragInlD name (inlineSpecNoPhase True True)
118 , funD name [clause [] (normalB (conE con)) []]
120 return (VarE name, decls)
122 genUnwrap ∷ Type → Q (Exp, [Dec])
124 = do name ← newName "unwrap"
126 (con, ty) ← wrapperConTy wrapperTy
128 [ sigD name [t| $(return wrapperTy) → $(return ty) |]
129 , pragInlD name (inlineSpecNoPhase True True)
130 , funD name [clause [conP con [varP i]] (normalB (varE i)) []]
132 return (VarE name, decls)
134 wrapperConTy ∷ Type → Q (Name, Type)
135 wrapperConTy = (conTy =≪) ∘ tyInfo
137 tyInfo ∷ Type → Q Info
138 tyInfo (ConT name) = reify name
139 tyInfo (AppT ty _) = tyInfo ty
140 tyInfo (SigT ty _) = tyInfo ty
142 = fail $ "wrapperConTy: unsupported type: " ⧺ pprint ty
144 conTy ∷ Info → Q (Name, Type)
145 conTy (TyConI (NewtypeD [] _ [] (NormalC con [(NotStrict, ty)]) []))
148 = fail $ "wrapperConTy: unsupported type: " ⧺ pprint info
150 methodNames ∷ Name → Q [Name]
151 methodNames = (names =≪) ∘ reify
153 names ∷ Info → Q [Name]
154 names (ClassI (ClassD _ _ _ _ decls) _)
155 = return ∘ catMaybes $ map name decls
156 names c = fail $ "methodNames: not a class: " ⧺ pprint c
158 name ∷ Dec → Maybe Name
159 name (SigD n _) = Just n
162 pointfreeMethod ∷ (Name → Q Exp) → Name → [Q Dec]
163 pointfreeMethod f name
164 = [ funD name [clause [] (normalB (f name)) []]
165 -- THINKME: Inserting PragmaD in an InstanceD causes an error
166 -- least GHC 7.0.3. Why?
167 -- , pragInlD name (inlineSpecNoPhase True False)
170 deriveUnfoldable ∷ Q Cxt → Q Type → Q Exp → Q Exp → Q Dec
171 deriveUnfoldable c ty wrap unwrap
172 = do names ← methodNames ''Unfoldable
173 instanceD c ty $ concatMap (pointfreeMethod exp) names
178 = [| ($wrap ∘) ∘ (∘ $unwrap) ∘ insert |]
182 = [| $wrap ∘ singleton |]
184 = [| ($wrap ∘) ∘ (∘ $unwrap) ∘ insertMany |]
185 | name ≡ 'insertManySorted
186 = [| ($wrap ∘) ∘ (∘ $unwrap) ∘ insertManySorted |]
188 = fail $ "deriveUnfoldable: unknown method: " ⧺ pprint name
190 deriveFoldable ∷ Q Cxt → Q Type → Q Exp → Q Exp → Q Dec
191 deriveFoldable c ty _ unwrap
192 = do names ← methodNames ''Foldable
193 instanceD c ty $ concatMap (pointfreeMethod exp) names
198 = [| fold ∘ $unwrap |]
200 = [| (∘ $unwrap) ∘ foldMap |]
202 = [| flip flip $unwrap ∘ ((∘) ∘) ∘ foldr |]
204 = [| flip flip $unwrap ∘ ((∘) ∘) ∘ foldl |]
206 = [| (∘ $unwrap) ∘ foldr1 |]
208 = [| (∘ $unwrap) ∘ foldl1 |]
210 = [| null ∘ $unwrap |]
212 = [| size ∘ $unwrap |]
213 | name ≡ 'isSingleton
214 = [| isSingleton ∘ $unwrap |]
216 = fail $ "deriveFoldable: unknown method: " ⧺ pprint name
218 deriveCollection ∷ Q Cxt → Q Type → Q Exp → Q Exp → Q Dec
219 deriveCollection c ty wrap unwrap
220 = do names ← methodNames ''Collection
221 instanceD c ty $ concatMap (pointfreeMethod exp) names
226 = [| ($wrap ∘) ∘ (∘ $unwrap) ∘ filter |]
228 = fail $ "deriveCollection: unknown method: " ⧺ pprint name
230 deriveIndexed ∷ Q Cxt → Q Type → Q Exp → Q Exp → Q Dec
231 deriveIndexed c ty wrap unwrap
232 = do names ← methodNames ''Indexed
233 instanceD c ty $ concatMap (pointfreeMethod exp) names
238 = [| (∘ $unwrap) ∘ index |]
240 = [| (($wrap ∘) ∘) ∘ flip flip $unwrap ∘ ((∘) ∘) ∘ adjust |]
242 = [| (∘ $unwrap) ∘ inDomain |]
244 = [| ($wrap ∘) ∘ (//) ∘ $unwrap |]
246 = [| (($wrap ∘) ∘) ∘ (∘ $unwrap) ∘ accum |]
248 = fail $ "deriveIndexed: unknown method: " ⧺ pprint name
250 deriveMap ∷ Q Cxt → Q Type → Q Exp → Q Exp → Q Dec
251 deriveMap c ty wrap unwrap
252 = do names ← methodNames ''Map
253 instanceD c ty $ concatMap (pointfreeMethod exp) names
258 = [| ($wrap ∘) ∘ (∘ $unwrap) ∘ delete |]
260 = [| (∘ $unwrap) ∘ member |]
262 = [| ($wrap ∘) ∘ (∘ $unwrap) ∘ union ∘ $unwrap |]
263 | name ≡ 'intersection
264 = [| ($wrap ∘) ∘ (∘ $unwrap) ∘ intersection ∘ $unwrap |]
266 = [| ($wrap ∘) ∘ (∘ $unwrap) ∘ difference ∘ $unwrap |]
268 = [| (∘ $unwrap) ∘ isSubset ∘ $unwrap |]
269 | name ≡ 'isProperSubset
270 = [| (∘ $unwrap) ∘ isProperSubset ∘ $unwrap |]
272 = [| (∘ $unwrap) ∘ lookup |]
274 = [| (($wrap ∘) ∘) ∘ flip flip $unwrap ∘ ((∘) ∘) ∘ alter |]
276 = [| ((($wrap ∘) ∘) ∘) ∘ flip flip $unwrap ∘ ((flip ∘ ((∘) ∘)) ∘) ∘ insertWith |]
277 | name ≡ 'fromFoldableWith
278 = [| ($wrap ∘) ∘ fromFoldableWith |]
280 = [| (($wrap ∘) ∘) ∘ foldGroups |]
282 = [| ($wrap ∘) ∘ (∘ $unwrap) ∘ mapWithKey |]
284 = [| (($wrap ∘) ∘) ∘ flip flip $unwrap ∘ ((∘) ∘) ∘ (∘ $unwrap) ∘ unionWith |]
285 | name ≡ 'intersectionWith
286 = [| (($wrap ∘) ∘) ∘ flip flip $unwrap ∘ ((∘) ∘) ∘ (∘ $unwrap) ∘ intersectionWith |]
287 | name ≡ 'differenceWith
288 = [| (($wrap ∘) ∘) ∘ flip flip $unwrap ∘ ((∘) ∘) ∘ (∘ $unwrap) ∘ differenceWith |]
290 = [| flip flip $unwrap ∘ ((∘) ∘) ∘ (∘ $unwrap) ∘ isSubmapBy |]
291 | name ≡ 'isProperSubmapBy
292 = [| flip flip $unwrap ∘ ((∘) ∘) ∘ (∘ $unwrap) ∘ isProperSubmapBy |]
294 = fail $ "deriveMap: unknown method: " ⧺ pprint name
296 deriveSet ∷ Q Cxt → Q Type → Q Exp → Q Exp → Q Dec
298 = do names ← methodNames ''Set
299 instanceD c ty $ concatMap (pointfreeMethod exp) names
303 | name ≡ 'haddock_candy
304 = [| haddock_candy |]
306 = fail $ "deriveSet: unknown method: " ⧺ pprint name
308 deriveSortingCollection ∷ Q Cxt → Q Type → Q Exp → Q Exp → Q Dec
309 deriveSortingCollection c ty wrap unwrap
310 = do names ← methodNames ''SortingCollection
311 instanceD c ty $ concatMap (pointfreeMethod exp) names
316 = [| (second $wrap <$>) ∘ minView ∘ $unwrap |]
318 = fail $ "deriveSortingCollection: unknown method: " ⧺ pprint name