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
  24                       , lookup, null
  25                       )
  26 import Prelude.Unicode
  27
  28 type Deriver = Q Cxt → Q Type → Q Exp → Q Exp → Q Dec
  29
  30 -- |FIXME: doc
  31 derive ∷ Q [Dec] → Q [Dec]
  32 derive = (concat <$>) ∘ (mapM go =≪)
  33     where
  34       go ∷ Dec → Q [Dec]
  35       go (InstanceD c ty _) = deriveInstance c ty
  36       go _ = fail "derive: usage: derive [d| instance A; instance B; ... |]"
  37
  38 deriveInstance ∷ Cxt → Type → Q [Dec]
  39 deriveInstance c ty
  40     = do (wrapperTy, deriver) ← inspectInstance ty
  41          (wrap     , wrapD  ) ← genWrap   wrapperTy
  42          (unwrap   , unwrapD) ← genUnwrap wrapperTy
  43          instanceDecl         ← deriver (return c     )
  44                                         (return ty    )
  45                                         (return wrap  )
  46                                         (return unwrap)
  47          return $ [ d | d ← wrapD  , wrap   `isUsedIn` instanceDecl ]
  48                 ⧺ [ d | d ← unwrapD, unwrap `isUsedIn` instanceDecl ]
  49                 ⧺ [ instanceDecl ]
  50
  51 isUsedIn ∷ (Eq α, Typeable α, Data β) ⇒ α → β → Bool
  52 isUsedIn α = (> 0) ∘ gcount (mkQ False (≡ α))
  53
  54 inspectInstance ∷ Type → Q (Type, Deriver)
  55 inspectInstance (AppT (AppT (ConT classTy) wrapperTy) _)
  56     | classTy ≡ ''Unfoldable
  57         = return (wrapperTy, deriveUnfoldable)
  58     | classTy ≡ ''Foldable
  59         = return (wrapperTy, deriveFoldable)
  60     | classTy ≡ ''Collection
  61         = return (wrapperTy, deriveCollection)
  62     | classTy ≡ ''Set
  63         = return (wrapperTy, deriveSet)
  64     | classTy ≡ ''SortingCollection
  65         = return (wrapperTy, deriveSortingCollection)
  66 inspectInstance (AppT (AppT (AppT (ConT classTy) wrapperTy) _) _)
  67     | classTy ≡ ''Indexed
  68         = return (wrapperTy, deriveIndexed)
  69     | classTy ≡ ''Map
  70         = return (wrapperTy, deriveMap)
  71 inspectInstance ty
  72     = fail $ "deriveInstance: unsupported type: " ⧺ pprint ty
  73
  74 genWrap ∷ Type → Q (Exp, [Dec])
  75 genWrap wrapperTy
  76     = do name      ← newName "wrap"
  77          (con, ty) ← wrapperConTy wrapperTy
  78          decls     ← sequence
  79                      [ sigD name [t| $(return ty) → $(return wrapperTy) |]
  80                      , pragInlD name (inlineSpecNoPhase True True)
  81                      , funD name [clause [] (normalB (conE con)) []]
  82                      ]
  83          return (VarE name, decls)
  84
  85 genUnwrap ∷ Type → Q (Exp, [Dec])
  86 genUnwrap wrapperTy
  87     = do name      ← newName "unwrap"
  88          i         ← newName "i"
  89          (con, ty) ← wrapperConTy wrapperTy
  90          decls     ← sequence
  91                      [ sigD name [t| $(return wrapperTy) → $(return ty) |]
  92                      , pragInlD name (inlineSpecNoPhase True True)
  93                      , funD name [clause [conP con [varP i]] (normalB (varE i)) []]
  94                      ]
  95          return (VarE name, decls)
  96
  97 wrapperConTy ∷ Type → Q (Name, Type)
  98 wrapperConTy = (conTy =≪) ∘ tyInfo
  99     where
 100       tyInfo ∷ Type → Q Info
 101       tyInfo (ConT name) = reify name
 102       tyInfo (AppT ty _) = tyInfo ty
 103       tyInfo (SigT ty _) = tyInfo ty
 104       tyInfo ty
 105           = fail $ "wrapperConTy: unsupported type: " ⧺ pprint ty
 106
 107       conTy ∷ Info → Q (Name, Type)
 108       conTy (TyConI (NewtypeD [] _ [] (NormalC con [(NotStrict, ty)]) []))
 109           = return (con, ty)
 110       conTy info
 111           = fail $ "wrapperConTy: unsupported type: " ⧺ pprint info
 112
 113 methodNames ∷ Name → Q [Name]
 114 methodNames = (names =≪) ∘ reify
 115     where
 116       names ∷ Info → Q [Name]
 117       names (ClassI (ClassD _ _ _ _ decls) _)
 118               = return ∘ catMaybes $ map name decls
 119       names c = fail $ "methodNames: not a class: " ⧺ pprint c
 120
 121       name ∷ Dec → Maybe Name
 122       name (SigD n _) = Just n
 123       name _          = Nothing
 124
 125 pointfreeMethod ∷ (Name → Q Exp) → Name → [Q Dec]
 126 pointfreeMethod f name
 127     = [ funD name [clause [] (normalB (f name)) []]
 128       -- THINKME: Inserting PragmaD in an InstanceD causes an error
 129       -- least GHC 7.0.3. Why?
 130       -- , pragInlD name (inlineSpecNoPhase True False)
 131       ]
 132
 133 deriveUnfoldable ∷ Q Cxt → Q Type → Q Exp → Q Exp → Q Dec
 134 deriveUnfoldable c ty wrap unwrap
 135     = do names ← methodNames ''Unfoldable
 136          instanceD c ty $ concatMap (pointfreeMethod exp) names
 137     where
 138       exp ∷ Name → Q Exp
 139       exp name
 140           | name ≡ 'insert
 141               = [| ($wrap ∘) ∘ (∘ $unwrap) ∘ insert |]
 142           | name ≡ 'empty
 143               = [| $wrap empty |]
 144           | name ≡ 'singleton
 145               = [| $wrap ∘ singleton |]
 146           | name ≡ 'insertMany
 147               = [| ($wrap ∘) ∘ (∘ $unwrap) ∘ insertMany |]
 148           | name ≡ 'insertManySorted
 149               = [| ($wrap ∘) ∘ (∘ $unwrap) ∘ insertManySorted |]
 150           | otherwise
 151               = fail $ "deriveUnfoldable: unknown method: " ⧺ pprint name
 152
 153 deriveFoldable ∷ Q Cxt → Q Type → Q Exp → Q Exp → Q Dec
 154 deriveFoldable c ty _ unwrap
 155     = do names ← methodNames ''Foldable
 156          instanceD c ty $ concatMap (pointfreeMethod exp) names
 157     where
 158       exp ∷ Name → Q Exp
 159       exp name
 160           | name ≡ 'fold
 161               = [| fold ∘ $unwrap |]
 162           | name ≡ 'foldMap
 163               = [| (∘ $unwrap) ∘ foldMap |]
 164           | name ≡ 'foldr
 165               = [| flip flip $unwrap ∘ ((∘) ∘) ∘ foldr |]
 166           | name ≡ 'foldl
 167               = [| flip flip $unwrap ∘ ((∘) ∘) ∘ foldl |]
 168           | name ≡ 'foldr1
 169               = [| (∘ $unwrap) ∘ foldr1 |]
 170           | name ≡ 'foldl1
 171               = [| (∘ $unwrap) ∘ foldl1 |]
 172           | name ≡ 'null
 173               = [| null ∘ $unwrap |]
 174           | name ≡ 'size
 175               = [| size ∘ $unwrap |]
 176           | name ≡ 'isSingleton
 177               = [| isSingleton ∘ $unwrap |]
 178           | otherwise
 179               = fail $ "deriveFoldable: unknown method: " ⧺ pprint name
 180
 181 deriveCollection ∷ Q Cxt → Q Type → Q Exp → Q Exp → Q Dec
 182 deriveCollection c ty wrap unwrap
 183     = do names ← methodNames ''Collection
 184          instanceD c ty $ concatMap (pointfreeMethod exp) names
 185     where
 186       exp ∷ Name → Q Exp
 187       exp name
 188           | name ≡ 'filter
 189               = [| ($wrap ∘) ∘ (∘ $unwrap) ∘ filter |]
 190           | otherwise
 191               = fail $ "deriveCollection: unknown method: " ⧺ pprint name
 192
 193 deriveIndexed ∷ Q Cxt → Q Type → Q Exp → Q Exp → Q Dec
 194 deriveIndexed c ty wrap unwrap
 195     = do names ← methodNames ''Indexed
 196          instanceD c ty $ concatMap (pointfreeMethod exp) names
 197     where
 198       exp ∷ Name → Q Exp
 199       exp name
 200           | name ≡ 'index
 201               = [| (∘ $unwrap) ∘ index |]
 202           | name ≡ 'adjust
 203               = [| (($wrap ∘) ∘) ∘ flip flip $unwrap ∘ ((∘) ∘) ∘ adjust |]
 204           | name ≡ 'inDomain
 205               = [| (∘ $unwrap) ∘ inDomain |]
 206           | name ≡ '(//)
 207               = [| ($wrap ∘) ∘ (//) ∘ $unwrap |]
 208           | name ≡ 'accum
 209               = [| (($wrap ∘) ∘) ∘ (∘ $unwrap) ∘ accum |]
 210           | otherwise
 211               = fail $ "deriveIndexed: unknown method: " ⧺ pprint name
 212
 213 deriveMap ∷ Q Cxt → Q Type → Q Exp → Q Exp → Q Dec
 214 deriveMap c ty wrap unwrap
 215     = do names ← methodNames ''Map
 216          instanceD c ty $ concatMap (pointfreeMethod exp) names
 217     where
 218       exp ∷ Name → Q Exp
 219       exp name
 220           | name ≡ 'delete
 221               = [| ($wrap ∘) ∘ (∘ $unwrap) ∘ delete |]
 222           | name ≡ 'member
 223               = [| (∘ $unwrap) ∘ member |]
 224           | name ≡ 'union
 225               = [| ($wrap ∘) ∘ (∘ $unwrap) ∘ union ∘ $unwrap |]
 226           | name ≡ 'intersection
 227               = [| ($wrap ∘) ∘ (∘ $unwrap) ∘ intersection ∘ $unwrap |]
 228           | name ≡ 'difference
 229               = [| ($wrap ∘) ∘ (∘ $unwrap) ∘ difference ∘ $unwrap |]
 230           | name ≡ 'isSubset
 231               = [| (∘ $unwrap) ∘ isSubset ∘ $unwrap |]
 232           | name ≡ 'isProperSubset
 233               = [| (∘ $unwrap) ∘ isProperSubset ∘ $unwrap |]
 234           | name ≡ 'lookup
 235               = [| (∘ $unwrap) ∘ lookup |]
 236           | name ≡ 'alter
 237               = [| (($wrap ∘) ∘) ∘ flip flip $unwrap ∘ ((∘) ∘) ∘ alter |]
 238           | name ≡ 'insertWith
 239               = [| ((($wrap ∘) ∘) ∘) ∘ flip flip $unwrap ∘ ((flip ∘ ((∘) ∘)) ∘) ∘ insertWith |]
 240           | name ≡ 'fromFoldableWith
 241               = [| ($wrap ∘) ∘ fromFoldableWith |]
 242           | name ≡ 'foldGroups
 243               = [| (($wrap ∘) ∘) ∘ foldGroups |]
 244           | name ≡ 'mapWithKey
 245               = [| ($wrap ∘) ∘ (∘ $unwrap) ∘ mapWithKey |]
 246           | name ≡ 'unionWith
 247               = [| (($wrap ∘) ∘) ∘ flip flip $unwrap ∘ ((∘) ∘) ∘ (∘ $unwrap) ∘ unionWith |]
 248           | name ≡ 'intersectionWith
 249               = [| (($wrap ∘) ∘) ∘ flip flip $unwrap ∘ ((∘) ∘) ∘ (∘ $unwrap) ∘ intersectionWith |]
 250           | name ≡ 'differenceWith
 251               = [| (($wrap ∘) ∘) ∘ flip flip $unwrap ∘ ((∘) ∘) ∘ (∘ $unwrap) ∘ differenceWith |]
 252           | name ≡ 'isSubmapBy
 253               = [| flip flip $unwrap ∘ ((∘) ∘) ∘ (∘ $unwrap) ∘ isSubmapBy |]
 254           | name ≡ 'isProperSubmapBy
 255               = [| flip flip $unwrap ∘ ((∘) ∘) ∘ (∘ $unwrap) ∘ isProperSubmapBy |]
 256           | otherwise
 257               = fail $ "deriveMap: unknown method: " ⧺ pprint name
 258
 259 deriveSet ∷ Q Cxt → Q Type → Q Exp → Q Exp → Q Dec
 260 deriveSet c ty _ _
 261     = do names ← methodNames ''Set
 262          instanceD c ty $ concatMap (pointfreeMethod exp) names
 263     where
 264       exp ∷ Name → Q Exp
 265       exp name
 266           | name ≡ 'haddock_candy
 267               = [| haddock_candy |]
 268           | otherwise
 269               = fail $ "deriveSet: unknown method: " ⧺ pprint name
 270
 271 deriveSortingCollection ∷ Q Cxt → Q Type → Q Exp → Q Exp → Q Dec
 272 deriveSortingCollection c ty wrap unwrap
 273     = do names ← methodNames ''SortingCollection
 274          instanceD c ty $ concatMap (pointfreeMethod exp) names
 275     where
 276       exp ∷ Name → Q Exp
 277       exp name
 278           | name ≡ 'minView
 279               = [| (second $wrap <$>) ∘ minView ∘ $unwrap |]
 280           | otherwise
 281               = fail $ "deriveSortingCollection: unknown method: " ⧺ pprint name