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.Arrow
  12 import Control.Monad.Unicode
  13 import Data.Collections
  14 import Data.Collections.BaseInstances ()
  15 import Data.Data
  16 import Data.Generics.Aliases
  17 import Data.Generics.Schemes
  18 import Data.Maybe
  19 import Language.Haskell.TH.Lib
  20 import Language.Haskell.TH.Ppr
  21 import Language.Haskell.TH.Syntax
  22 import Prelude hiding ( concat, concatMap, exp, filter
  23                       , foldl, foldr, foldl1, foldr1, null)
  24 import Prelude.Unicode
  25
  26 type Deriver = Q Cxt → Q Type → Q Exp → Q Exp → Q Dec
  27
  28 -- |FIXME: doc
  29 derive ∷ Q [Dec] → Q [Dec]
  30 derive = (concat <$>) ∘ (mapM go =≪)
  31     where
  32       go ∷ Dec → Q [Dec]
  33       go (InstanceD c ty _) = deriveInstance c ty
  34       go _ = fail "derive: usage: derive [d| instance A; instance B; ... |]"
  35
  36 deriveInstance ∷ Cxt → Type → Q [Dec]
  37 deriveInstance c ty
  38     = do (wrapperTy, deriver) ← inspectInstance ty
  39          (wrap     , wrapD  ) ← genWrap   wrapperTy
  40          (unwrap   , unwrapD) ← genUnwrap wrapperTy
  41          instanceDecl         ← deriver (return c     )
  42                                         (return ty    )
  43                                         (return wrap  )
  44                                         (return unwrap)
  45          return $ [ d | d ← wrapD  , wrap   `isUsedIn` instanceDecl ]
  46                 ⧺ [ d | d ← unwrapD, unwrap `isUsedIn` instanceDecl ]
  47                 ⧺ [ instanceDecl ]
  48
  49 isUsedIn ∷ (Eq α, Typeable α, Data β) ⇒ α → β → Bool
  50 isUsedIn α = (> 0) ∘ gcount (mkQ False (≡ α))
  51
  52 inspectInstance ∷ Type → Q (Type, Deriver)
  53 inspectInstance (AppT (AppT (ConT classTy) wrapperTy) _)
  54     | classTy ≡ ''Unfoldable
  55         = return (wrapperTy, deriveUnfoldable)
  56     | classTy ≡ ''Foldable
  57         = return (wrapperTy, deriveFoldable)
  58     | classTy ≡ ''Collection
  59         = return (wrapperTy, deriveCollection)
  60     | classTy ≡ ''SortingCollection
  61         = return (wrapperTy, deriveSortingCollection)
  62 inspectInstance (AppT (AppT (AppT (ConT classTy) wrapperTy) _) _)
  63     | classTy ≡ ''Indexed
  64         = return (wrapperTy, deriveIndexed)
  65 inspectInstance ty
  66     = fail $ "deriveInstance: unsupported type: " ⧺ pprint ty
  67
  68 genWrap ∷ Type → Q (Exp, [Dec])
  69 genWrap wrapperTy
  70     = do name      ← newName "wrap"
  71          (con, ty) ← wrapperConTy wrapperTy
  72          decls     ← sequence
  73                      [ sigD name [t| $(return ty) → $(return wrapperTy) |]
  74                      , pragInlD name (inlineSpecNoPhase True True)
  75                      , funD name [clause [] (normalB (conE con)) []]
  76                      ]
  77          return (VarE name, decls)
  78
  79 genUnwrap ∷ Type → Q (Exp, [Dec])
  80 genUnwrap wrapperTy
  81     = do name      ← newName "unwrap"
  82          i         ← newName "i"
  83          (con, ty) ← wrapperConTy wrapperTy
  84          decls     ← sequence
  85                      [ sigD name [t| $(return wrapperTy) → $(return ty) |]
  86                      , pragInlD name (inlineSpecNoPhase True True)
  87                      , funD name [clause [conP con [varP i]] (normalB (varE i)) []]
  88                      ]
  89          return (VarE name, decls)
  90
  91 wrapperConTy ∷ Type → Q (Name, Type)
  92 wrapperConTy = (conTy =≪) ∘ tyInfo
  93     where
  94       tyInfo ∷ Type → Q Info
  95       tyInfo (ConT name) = reify name
  96       tyInfo (AppT ty _) = tyInfo ty
  97       tyInfo (SigT ty _) = tyInfo ty
  98       tyInfo ty
  99           = fail $ "wrapperConTy: unsupported type: " ⧺ pprint ty
 100
 101       conTy ∷ Info → Q (Name, Type)
 102       conTy (TyConI (NewtypeD [] _ [] (NormalC con [(NotStrict, ty)]) []))
 103           = return (con, ty)
 104       conTy info
 105           = fail $ "wrapperConTy: unsupported type: " ⧺ pprint info
 106
 107 methodNames ∷ Name → Q [Name]
 108 methodNames = (names =≪) ∘ reify
 109     where
 110       names ∷ Info → Q [Name]
 111       names (ClassI (ClassD _ _ _ _ decls) _)
 112               = return ∘ catMaybes $ map name decls
 113       names c = fail $ "methodNames: not a class: " ⧺ pprint c
 114
 115       name ∷ Dec → Maybe Name
 116       name (SigD n _) = Just n
 117       name _          = Nothing
 118
 119 pointfreeMethod ∷ (Name → Q Exp) → Name → [Q Dec]
 120 pointfreeMethod f name
 121     = [ funD name [clause [] (normalB (f name)) []]
 122       -- THINKME: Inserting PragmaD in an InstanceD causes an error
 123       -- least GHC 7.0.3. Why?
 124       -- , pragInlD name (inlineSpecNoPhase True False)
 125       ]
 126
 127 deriveUnfoldable ∷ Q Cxt → Q Type → Q Exp → Q Exp → Q Dec
 128 deriveUnfoldable c ty wrap unwrap
 129     = do names ← methodNames ''Unfoldable
 130          instanceD c ty $ concatMap (pointfreeMethod exp) names
 131     where
 132       exp ∷ Name → Q Exp
 133       exp name
 134           | name ≡ 'insert
 135               = [| ($wrap ∘) ∘ (∘ $unwrap) ∘ insert |]
 136           | name ≡ 'empty
 137               = [| $wrap empty |]
 138           | name ≡ 'singleton
 139               = [| $wrap ∘ singleton |]
 140           | name ≡ 'insertMany
 141               = [| ($wrap ∘) ∘ (∘ $unwrap) ∘ insertMany |]
 142           | name ≡ 'insertManySorted
 143               = [| ($wrap ∘) ∘ (∘ $unwrap) ∘ insertManySorted |]
 144           | otherwise
 145               = fail $ "deriveUnfoldable: unknown method: " ⧺ pprint name
 146
 147 deriveFoldable ∷ Q Cxt → Q Type → Q Exp → Q Exp → Q Dec
 148 deriveFoldable c ty _ unwrap
 149     = do names ← methodNames ''Foldable
 150          instanceD c ty $ concatMap (pointfreeMethod exp) names
 151     where
 152       exp ∷ Name → Q Exp
 153       exp name
 154           | name ≡ 'fold
 155               = [| fold ∘ $unwrap |]
 156           | name ≡ 'foldMap
 157               = [| (∘ $unwrap) ∘ foldMap |]
 158           | name ≡ 'foldr
 159               = [| flip flip $unwrap ∘ ((∘) ∘) ∘ foldr |]
 160           | name ≡ 'foldl
 161               = [| flip flip $unwrap ∘ ((∘) ∘) ∘ foldl |]
 162           | name ≡ 'foldr1
 163               = [| (∘ $unwrap) ∘ foldr1 |]
 164           | name ≡ 'foldl1
 165               = [| (∘ $unwrap) ∘ foldl1 |]
 166           | name ≡ 'null
 167               = [| null ∘ $unwrap |]
 168           | name ≡ 'size
 169               = [| size ∘ $unwrap |]
 170           | name ≡ 'isSingleton
 171               = [| isSingleton ∘ $unwrap |]
 172           | otherwise
 173               = fail $ "deriveFoldable: unknown method: " ⧺ pprint name
 174
 175 deriveCollection ∷ Q Cxt → Q Type → Q Exp → Q Exp → Q Dec
 176 deriveCollection c ty wrap unwrap
 177     = do names ← methodNames ''Collection
 178          instanceD c ty $ concatMap (pointfreeMethod exp) names
 179     where
 180       exp ∷ Name → Q Exp
 181       exp name
 182           | name ≡ 'filter
 183               = [| ($wrap ∘) ∘ (∘ $unwrap) ∘ filter |]
 184           | otherwise
 185               = fail $ "deriveCollection: unknown method: " ⧺ pprint name
 186
 187 deriveIndexed ∷ Q Cxt → Q Type → Q Exp → Q Exp → Q Dec
 188 deriveIndexed c ty wrap unwrap
 189     = do names ← methodNames ''Indexed
 190          instanceD c ty $ concatMap (pointfreeMethod exp) names
 191     where
 192       exp ∷ Name → Q Exp
 193       exp name
 194           | name ≡ 'index
 195               = [| (∘ $unwrap) ∘ index |]
 196           | name ≡ 'adjust
 197               = [| (($wrap ∘) ∘) ∘ flip flip $unwrap ∘ ((∘) ∘) ∘ adjust |]
 198           | name ≡ 'inDomain
 199               = [| (∘ $unwrap) ∘ inDomain |]
 200           | name ≡ '(//)
 201               = [| ($wrap ∘) ∘ (//) ∘ $unwrap |]
 202           | name ≡ 'accum
 203               = [| (($wrap ∘) ∘) ∘ (∘ $unwrap) ∘ accum |]
 204           | otherwise
 205               = fail $ "deriveIndexed: unknown method: " ⧺ pprint name
 206
 207 deriveSortingCollection ∷ Q Cxt → Q Type → Q Exp → Q Exp → Q Dec
 208 deriveSortingCollection c ty wrap unwrap
 209     = do names ← methodNames ''SortingCollection
 210          instanceD c ty $ concatMap (pointfreeMethod exp) names
 211     where
 212       exp ∷ Name → Q Exp
 213       exp name
 214           | name ≡ 'minView
 215               = [| (second $wrap <$>) ∘ minView ∘ $unwrap |]
 216           | otherwise
 217               = fail $ "deriveSortingCollection: unknown method: " ⧺ pprint name