Data/Collections/Newtype/TH.hs

   1 {-# LANGUAGE
   2     TemplateHaskell
   3   , UnicodeSyntax
   4   #-}
   5 -- |FIXME: doc
   6 module Data.Collections.Newtype.TH
   7     ( derive
   8     )
   9     where
  10 import Control.Applicative hiding (empty)
  11 import Control.Monad.Unicode
  12 import Data.Collections
  13 import Data.Collections.BaseInstances ()
  14 import Data.Data
  15 import Data.Generics.Aliases
  16 import Data.Generics.Schemes
  17 import Data.Maybe
  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
  24
  25 type Deriver = Q Cxt → Q Type → Q Exp → Q Exp → Q Dec
  26
  27 -- |FIXME: doc
  28 derive ∷ Q [Dec] → Q [Dec]
  29 derive = (concat <$>) ∘ (mapM go =≪)
  30     where
  31       go ∷ Dec → Q [Dec]
  32       go (InstanceD c ty _) = deriveInstance c ty
  33       go _ = fail "derive: usage: derive [d| instance A; instance B; ... |]"
  34
  35 deriveInstance ∷ Cxt → Type → Q [Dec]
  36 deriveInstance c ty
  37     = do (wrapperTy, deriver) ← inspectInstance ty
  38          (wrap     , wrapD  ) ← genWrap   wrapperTy
  39          (unwrap   , unwrapD) ← genUnwrap wrapperTy
  40          instanceDecl         ← deriver (return c     )
  41                                         (return ty    )
  42                                         (return wrap  )
  43                                         (return unwrap)
  44          return $ [ d | d ← wrapD  , wrap   `isUsedIn` instanceDecl ]
  45                 ⧺ [ d | d ← unwrapD, unwrap `isUsedIn` instanceDecl ]
  46                 ⧺ [ instanceDecl ]
  47
  48 isUsedIn ∷ (Eq α, Typeable α, Data β) ⇒ α → β → Bool
  49 isUsedIn α = (> 0) ∘ gcount (mkQ False (≡ α))
  50
  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) _) _)
  60     | classTy ≡ ''Indexed
  61         = return (wrapperTy, deriveIndexed)
  62 inspectInstance ty
  63     = fail $ "deriveInstance: unsupported type: " ⧺ pprint ty
  64
  65 genWrap ∷ Type → Q (Exp, [Dec])
  66 genWrap wrapperTy
  67     = do name      ← newName "wrap"
  68          (con, ty) ← wrapperConTy wrapperTy
  69          decls     ← sequence
  70                      [ sigD name [t| $(return ty) → $(return wrapperTy) |]
  71                      , pragInlD name (inlineSpecNoPhase True True)
  72                      , funD name [clause [] (normalB (conE con)) []]
  73                      ]
  74          return (VarE name, decls)
  75
  76 genUnwrap ∷ Type → Q (Exp, [Dec])
  77 genUnwrap wrapperTy
  78     = do name      ← newName "unwrap"
  79          i         ← newName "i"
  80          (con, ty) ← wrapperConTy wrapperTy
  81          decls     ← sequence
  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)) []]
  85                      ]
  86          return (VarE name, decls)
  87
  88 wrapperConTy ∷ Type → Q (Name, Type)
  89 wrapperConTy = (conTy =≪) ∘ tyInfo
  90     where
  91       tyInfo ∷ Type → Q Info
  92       tyInfo (ConT name) = reify name
  93       tyInfo (AppT ty _) = tyInfo ty
  94       tyInfo (SigT ty _) = tyInfo ty
  95       tyInfo ty
  96           = fail $ "wrapperConTy: unsupported type: " ⧺ pprint ty
  97
  98       conTy ∷ Info → Q (Name, Type)
  99       conTy (TyConI (NewtypeD [] _ [] (NormalC con [(NotStrict, ty)]) []))
 100           = return (con, ty)
 101       conTy info
 102           = fail $ "wrapperConTy: unsupported type: " ⧺ pprint info
 103
 104 methodNames ∷ Name → Q [Name]
 105 methodNames = (names =≪) ∘ reify
 106     where
 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
 111
 112       name ∷ Dec → Maybe Name
 113       name (SigD n _) = Just n
 114       name _          = Nothing
 115
 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)
 122       ]
 123
 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
 128     where
 129       exp ∷ Name → Q Exp
 130       exp name
 131           | name ≡ 'insert
 132               = [| ($wrap ∘) ∘ (∘ $unwrap) ∘ insert |]
 133           | name ≡ 'empty
 134               = [| $wrap empty |]
 135           | name ≡ 'singleton
 136               = [| $wrap ∘ singleton |]
 137           | name ≡ 'insertMany
 138               = [| ($wrap ∘) ∘ (∘ $unwrap) ∘ insertMany |]
 139           | name ≡ 'insertManySorted
 140               = [| ($wrap ∘) ∘ (∘ $unwrap) ∘ insertManySorted |]
 141           | otherwise
 142               = fail $ "deriveUnfoldable: unknown method: " ⧺ pprint name
 143
 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
 148     where
 149       exp ∷ Name → Q Exp
 150       exp name
 151           | name ≡ 'fold
 152               = [| fold ∘ $unwrap |]
 153           | name ≡ 'foldMap
 154               = [| (∘ $unwrap) ∘ foldMap |]
 155           | name ≡ 'foldr
 156               = [| flip flip $unwrap ∘ ((∘) ∘) ∘ foldr |]
 157           | name ≡ 'foldl
 158               = [| flip flip $unwrap ∘ ((∘) ∘) ∘ foldl |]
 159           | name ≡ 'foldr1
 160               = [| (∘ $unwrap) ∘ foldr1 |]
 161           | name ≡ 'foldl1
 162               = [| (∘ $unwrap) ∘ foldl1 |]
 163           | name ≡ 'null
 164               = [| null ∘ $unwrap |]
 165           | name ≡ 'size
 166               = [| size ∘ $unwrap |]
 167           | name ≡ 'isSingleton
 168               = [| isSingleton ∘ $unwrap |]
 169           | otherwise
 170               = fail $ "deriveFoldable: unknown method: " ⧺ pprint name
 171
 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
 176     where
 177       exp ∷ Name → Q Exp
 178       exp name
 179           | name ≡ 'filter
 180               = [| ($wrap ∘) ∘ (∘ $unwrap) ∘ filter |]
 181           | otherwise
 182               = fail $ "deriveCollection: unknown method: " ⧺ pprint name
 183
 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
 188     where
 189       exp ∷ Name → Q Exp
 190       exp name
 191           | name ≡ 'index
 192               = [| (∘ $unwrap) ∘ index |]
 193           | name ≡ 'adjust
 194               = [| (($wrap ∘) ∘) ∘ flip flip $unwrap ∘ ((∘) ∘) ∘ adjust |]
 195           | name ≡ 'inDomain
 196               = [| (∘ $unwrap) ∘ inDomain |]
 197           | name ≡ '(//)
 198               = [| ($wrap ∘) ∘ (//) ∘ $unwrap |]
 199           | name ≡ 'accum
 200               = [| (($wrap ∘) ∘) ∘ (∘ $unwrap) ∘ accum |]
 201           | otherwise
 202               = fail $ "deriveIndexed: unknown method: " ⧺ pprint name