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.Maybe
  15 import Language.Haskell.TH.Lib
  16 import Language.Haskell.TH.Ppr
  17 import Language.Haskell.TH.Syntax
  18 import Prelude hiding (concat, exp)
  19 import Prelude.Unicode
  20
  21 type Deriver = Q Cxt → Q Type → Q Exp → Q Exp → Q Dec
  22
  23 -- |FIXME: doc
  24 derive ∷ Q [Dec] → Q [Dec]
  25 derive = (concat <$>) ∘ (mapM go =≪)
  26     where
  27       go ∷ Dec → Q [Dec]
  28       go (InstanceD c ty _) = deriveInstance c ty
  29       go _ = fail "derive: usage: derive [d| instance A; instance B; ... |]"
  30
  31 deriveInstance ∷ Cxt → Type → Q [Dec]
  32 deriveInstance c ty
  33     = do (wrapperTy, deriver) ← inspectInstance ty
  34          (wrap     , wrapD  ) ← genWrap   wrapperTy
  35          (unwrap   , unwrapD) ← genUnwrap wrapperTy
  36          (: wrapD ⧺ unwrapD) <$> deriver (return c     )
  37                                          (return ty    )
  38                                          (return wrap  )
  39                                          (return unwrap)
  40
  41 inspectInstance ∷ Type → Q (Type, Deriver)
  42 inspectInstance (AppT (AppT (ConT classTy) wrapperTy) _)
  43     | classTy ≡ ''Unfoldable
  44         = return (wrapperTy, deriveUnfoldable)
  45 inspectInstance ty
  46     = fail $ "deriveInstance: unsupported type: " ⧺ pprint ty
  47
  48 genWrap ∷ Type → Q (Exp, [Dec])
  49 genWrap wrapperTy
  50     = do name      ← newName "wrap"
  51          (con, ty) ← wrapperConTy wrapperTy
  52          decls     ← sequence
  53                      [ sigD name [t| $(return ty) → $(return wrapperTy) |]
  54                      , pragInlD name (inlineSpecNoPhase True True)
  55                      , funD name [clause [] (normalB (conE con)) []]
  56                      ]
  57          return (VarE name, decls)
  58
  59 genUnwrap ∷ Type → Q (Exp, [Dec])
  60 genUnwrap wrapperTy
  61     = do name      ← newName "unwrap"
  62          i         ← newName "i"
  63          (con, ty) ← wrapperConTy wrapperTy
  64          decls     ← sequence
  65                      [ sigD name [t| $(return wrapperTy) → $(return ty) |]
  66                      , pragInlD name (inlineSpecNoPhase True True)
  67                      , funD name [clause [conP con [varP i]] (normalB (varE i)) []]
  68                      ]
  69          return (VarE name, decls)
  70
  71 wrapperConTy ∷ Type → Q (Name, Type)
  72 wrapperConTy = (conTy =≪) ∘ tyInfo
  73     where
  74       tyInfo ∷ Type → Q Info
  75       tyInfo (ConT name) = reify name
  76       tyInfo (AppT ty _) = tyInfo ty
  77       tyInfo (SigT ty _) = tyInfo ty
  78       tyInfo ty
  79           = fail $ "wrapperConTy: unsupported type: " ⧺ pprint ty
  80
  81       conTy ∷ Info → Q (Name, Type)
  82       conTy (TyConI (NewtypeD [] _ [] (NormalC con [(NotStrict, ty)]) []))
  83           = return (con, ty)
  84       conTy info
  85           = fail $ "wrapperConTy: unsupported type: " ⧺ pprint info
  86
  87 methodNames ∷ Name → Q [Name]
  88 methodNames = (names =≪) ∘ reify
  89     where
  90       names ∷ Info → Q [Name]
  91       names (ClassI (ClassD _ _ _ _ decls) _)
  92               = return ∘ catMaybes $ map name decls
  93       names c = fail $ "methodNames: not a class: " ⧺ pprint c
  94
  95       name ∷ Dec → Maybe Name
  96       name (SigD n _) = Just n
  97       name _          = Nothing
  98
  99 pointfreeMethod ∷ (Name → Q Exp) → Name → Q Dec
 100 pointfreeMethod f name
 101     = funD name [clause [] (normalB (f name)) []]
 102
 103 deriveUnfoldable ∷ Q Cxt → Q Type → Q Exp → Q Exp → Q Dec
 104 deriveUnfoldable c ty wrap unwrap
 105     = do names ← methodNames ''Unfoldable
 106          instanceD c ty $ pointfreeMethod exp <$> names
 107     where
 108       exp ∷ Name → Q Exp
 109       exp name
 110           | name ≡ 'insert
 111               = [| ($wrap ∘) ∘ (∘ $unwrap) ∘ insert |]
 112           | name ≡ 'empty
 113               = [| $wrap empty |]
 114           | name ≡ 'singleton
 115               = [| $wrap ∘ singleton |]
 116           | name ≡ 'insertMany
 117               = [| ($wrap ∘) ∘ (∘ $unwrap) ∘ insertMany |]
 118           | name ≡ 'insertManySorted
 119               = [| ($wrap ∘) ∘ (∘ $unwrap) ∘ insertManySorted |]
 120           | otherwise
 121               = fail $ "deriveUnfoldable: unknown method: " ⧺ pprint name
 122
 123 {-
 124 instance Unfoldable MIMEParams (CIAscii, Text) where
 125     {-# INLINE insert #-}
 126     insert p (MIMEParams m)
 127         = MIMEParams $ insert p m
 128     {-# INLINE empty #-}
 129     empty
 130         = MIMEParams empty
 131     {-# INLINE singleton #-}
 132     singleton p
 133         = MIMEParams $ singleton p
 134     {-# INLINE insertMany #-}
 135     insertMany f (MIMEParams m)
 136         = MIMEParams $ insertMany f m
 137     {-# INLINE insertManySorted #-}
 138     insertManySorted f (MIMEParams m)
 139         = MIMEParams $ insertManySorted f m
 140 -}