Data/Collections/Newtype/TH.hs

   1 {-# LANGUAGE
   2     TemplateHaskell
   3   , UnicodeSyntax
   4   #-}
   5 -- |Doesn't anyone know why these instances can't be derived using
   6 -- GeneralizedNewtypeDeriving? I think its limitation isn't reasonable
   7 -- at all...
   8 module Data.Collections.Newtype.TH
   9     ( derive
  10     )
  11     where
  12 import Control.Applicative hiding (empty)
  13 import Control.Arrow
  14 import Control.Monad.Unicode
  15 import Data.Collections
  16 import Data.Collections.BaseInstances ()
  17 import Data.Data
  18 import Data.Generics.Aliases
  19 import Data.Generics.Schemes
  20 import Data.Maybe
  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
  26                       , lookup, null
  27                       )
  28 import Prelude.Unicode
  29
  30 type Deriver = Q Cxt → Q Type → Q Exp → Q Exp → Q Dec
  31
  32 -- |Automatic newtype instance deriver for type classes defined by the
  33 -- collections-api package.
  34 --
  35 -- @
  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
  42 --
  43 --   newtype T = T (M.Map 'Int' 'Bool')
  44 --
  45 --   C.derive [d| instance 'Unfoldable' T ('Int', 'Bool')
  46 --                instance 'Foldable'   T ('Int', 'Bool')
  47 --                instance 'Indexed'    T  'Int'  'Bool'
  48 --                ...
  49 --              |]
  50 -- @
  51 --
  52 -- This function can derive the following instances:
  53 --
  54 --   * 'Unfoldable'
  55 --
  56 --   * 'Foldable'
  57 --
  58 --   * 'Collection'
  59 --
  60 --   * 'Indexed'
  61 --
  62 --   * 'Map'
  63 --
  64 --   * 'Set'
  65 --
  66 --   * 'SortingCollection'
  67 --
  68 derive ∷ Q [Dec] → Q [Dec]
  69 derive = (concat <$>) ∘ (mapM go =≪)
  70     where
  71       go ∷ Dec → Q [Dec]
  72       go (InstanceD c ty _) = deriveInstance c ty
  73       go _ = fail "derive: usage: derive [d| instance A; instance B; ... |]"
  74
  75 deriveInstance ∷ Cxt → Type → Q [Dec]
  76 deriveInstance c ty
  77     = do (wrapperTy, deriver) ← inspectInstance ty
  78          (wrap     , wrapD  ) ← genWrap   wrapperTy
  79          (unwrap   , unwrapD) ← genUnwrap wrapperTy
  80          instanceDecl         ← deriver (return c     )
  81                                         (return ty    )
  82                                         (return wrap  )
  83                                         (return unwrap)
  84          return $ [ d | d ← wrapD  , wrap   `isUsedIn` instanceDecl ]
  85                 ⧺ [ d | d ← unwrapD, unwrap `isUsedIn` instanceDecl ]
  86                 ⧺ [ instanceDecl ]
  87
  88 isUsedIn ∷ (Eq α, Typeable α, Data β) ⇒ α → β → Bool
  89 isUsedIn α = (> 0) ∘ gcount (mkQ False (≡ α))
  90
  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)
  99     | classTy ≡ ''Set
 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)
 106     | classTy ≡ ''Map
 107         = return (wrapperTy, deriveMap)
 108 inspectInstance ty
 109     = fail $ "deriveInstance: unsupported type: " ⧺ pprint ty
 110
 111 genWrap ∷ Type → Q (Exp, [Dec])
 112 genWrap wrapperTy
 113     = do name      ← newName "wrap"
 114          (con, ty) ← wrapperConTy wrapperTy
 115          decls     ← sequence
 116                      [ sigD name [t| $(return ty) → $(return wrapperTy) |]
 117                      , pragInlD name (inlineSpecNoPhase True True)
 118                      , funD name [clause [] (normalB (conE con)) []]
 119                      ]
 120          return (VarE name, decls)
 121
 122 genUnwrap ∷ Type → Q (Exp, [Dec])
 123 genUnwrap wrapperTy
 124     = do name      ← newName "unwrap"
 125          i         ← newName "i"
 126          (con, ty) ← wrapperConTy wrapperTy
 127          decls     ← sequence
 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)) []]
 131                      ]
 132          return (VarE name, decls)
 133
 134 wrapperConTy ∷ Type → Q (Name, Type)
 135 wrapperConTy = (conTy =≪) ∘ tyInfo
 136     where
 137       tyInfo ∷ Type → Q Info
 138       tyInfo (ConT name) = reify name
 139       tyInfo (AppT ty _) = tyInfo ty
 140       tyInfo (SigT ty _) = tyInfo ty
 141       tyInfo ty
 142           = fail $ "wrapperConTy: unsupported type: " ⧺ pprint ty
 143
 144       conTy ∷ Info → Q (Name, Type)
 145       conTy (TyConI (NewtypeD [] _ [] (NormalC con [(NotStrict, ty)]) []))
 146           = return (con, ty)
 147       conTy info
 148           = fail $ "wrapperConTy: unsupported type: " ⧺ pprint info
 149
 150 methodNames ∷ Name → Q [Name]
 151 methodNames = (names =≪) ∘ reify
 152     where
 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
 157
 158       name ∷ Dec → Maybe Name
 159       name (SigD n _) = Just n
 160       name _          = Nothing
 161
 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)
 168       ]
 169
 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
 174     where
 175       exp ∷ Name → Q Exp
 176       exp name
 177           | name ≡ 'insert
 178               = [| ($wrap ∘) ∘ (∘ $unwrap) ∘ insert |]
 179           | name ≡ 'empty
 180               = [| $wrap empty |]
 181           | name ≡ 'singleton
 182               = [| $wrap ∘ singleton |]
 183           | name ≡ 'insertMany
 184               = [| ($wrap ∘) ∘ (∘ $unwrap) ∘ insertMany |]
 185           | name ≡ 'insertManySorted
 186               = [| ($wrap ∘) ∘ (∘ $unwrap) ∘ insertManySorted |]
 187           | otherwise
 188               = fail $ "deriveUnfoldable: unknown method: " ⧺ pprint name
 189
 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
 194     where
 195       exp ∷ Name → Q Exp
 196       exp name
 197           | name ≡ 'fold
 198               = [| fold ∘ $unwrap |]
 199           | name ≡ 'foldMap
 200               = [| (∘ $unwrap) ∘ foldMap |]
 201           | name ≡ 'foldr
 202               = [| flip flip $unwrap ∘ ((∘) ∘) ∘ foldr |]
 203           | name ≡ 'foldl
 204               = [| flip flip $unwrap ∘ ((∘) ∘) ∘ foldl |]
 205           | name ≡ 'foldr1
 206               = [| (∘ $unwrap) ∘ foldr1 |]
 207           | name ≡ 'foldl1
 208               = [| (∘ $unwrap) ∘ foldl1 |]
 209           | name ≡ 'null
 210               = [| null ∘ $unwrap |]
 211           | name ≡ 'size
 212               = [| size ∘ $unwrap |]
 213           | name ≡ 'isSingleton
 214               = [| isSingleton ∘ $unwrap |]
 215           | otherwise
 216               = fail $ "deriveFoldable: unknown method: " ⧺ pprint name
 217
 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
 222     where
 223       exp ∷ Name → Q Exp
 224       exp name
 225           | name ≡ 'filter
 226               = [| ($wrap ∘) ∘ (∘ $unwrap) ∘ filter |]
 227           | otherwise
 228               = fail $ "deriveCollection: unknown method: " ⧺ pprint name
 229
 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
 234     where
 235       exp ∷ Name → Q Exp
 236       exp name
 237           | name ≡ 'index
 238               = [| (∘ $unwrap) ∘ index |]
 239           | name ≡ 'adjust
 240               = [| (($wrap ∘) ∘) ∘ flip flip $unwrap ∘ ((∘) ∘) ∘ adjust |]
 241           | name ≡ 'inDomain
 242               = [| (∘ $unwrap) ∘ inDomain |]
 243           | name ≡ '(//)
 244               = [| ($wrap ∘) ∘ (//) ∘ $unwrap |]
 245           | name ≡ 'accum
 246               = [| (($wrap ∘) ∘) ∘ (∘ $unwrap) ∘ accum |]
 247           | otherwise
 248               = fail $ "deriveIndexed: unknown method: " ⧺ pprint name
 249
 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
 254     where
 255       exp ∷ Name → Q Exp
 256       exp name
 257           | name ≡ 'delete
 258               = [| ($wrap ∘) ∘ (∘ $unwrap) ∘ delete |]
 259           | name ≡ 'member
 260               = [| (∘ $unwrap) ∘ member |]
 261           | name ≡ 'union
 262               = [| ($wrap ∘) ∘ (∘ $unwrap) ∘ union ∘ $unwrap |]
 263           | name ≡ 'intersection
 264               = [| ($wrap ∘) ∘ (∘ $unwrap) ∘ intersection ∘ $unwrap |]
 265           | name ≡ 'difference
 266               = [| ($wrap ∘) ∘ (∘ $unwrap) ∘ difference ∘ $unwrap |]
 267           | name ≡ 'isSubset
 268               = [| (∘ $unwrap) ∘ isSubset ∘ $unwrap |]
 269           | name ≡ 'isProperSubset
 270               = [| (∘ $unwrap) ∘ isProperSubset ∘ $unwrap |]
 271           | name ≡ 'lookup
 272               = [| (∘ $unwrap) ∘ lookup |]
 273           | name ≡ 'alter
 274               = [| (($wrap ∘) ∘) ∘ flip flip $unwrap ∘ ((∘) ∘) ∘ alter |]
 275           | name ≡ 'insertWith
 276               = [| ((($wrap ∘) ∘) ∘) ∘ flip flip $unwrap ∘ ((flip ∘ ((∘) ∘)) ∘) ∘ insertWith |]
 277           | name ≡ 'fromFoldableWith
 278               = [| ($wrap ∘) ∘ fromFoldableWith |]
 279           | name ≡ 'foldGroups
 280               = [| (($wrap ∘) ∘) ∘ foldGroups |]
 281           | name ≡ 'mapWithKey
 282               = [| ($wrap ∘) ∘ (∘ $unwrap) ∘ mapWithKey |]
 283           | name ≡ 'unionWith
 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 |]
 289           | name ≡ 'isSubmapBy
 290               = [| flip flip $unwrap ∘ ((∘) ∘) ∘ (∘ $unwrap) ∘ isSubmapBy |]
 291           | name ≡ 'isProperSubmapBy
 292               = [| flip flip $unwrap ∘ ((∘) ∘) ∘ (∘ $unwrap) ∘ isProperSubmapBy |]
 293           | otherwise
 294               = fail $ "deriveMap: unknown method: " ⧺ pprint name
 295
 296 deriveSet ∷ Q Cxt → Q Type → Q Exp → Q Exp → Q Dec
 297 deriveSet c ty _ _
 298     = do names ← methodNames ''Set
 299          instanceD c ty $ concatMap (pointfreeMethod exp) names
 300     where
 301       exp ∷ Name → Q Exp
 302       exp name
 303           | name ≡ 'haddock_candy
 304               = [| haddock_candy |]
 305           | otherwise
 306               = fail $ "deriveSet: unknown method: " ⧺ pprint name
 307
 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
 312     where
 313       exp ∷ Name → Q Exp
 314       exp name
 315           | name ≡ 'minView
 316               = [| (second $wrap <$>) ∘ minView ∘ $unwrap |]
 317           | otherwise
 318               = fail $ "deriveSortingCollection: unknown method: " ⧺ pprint name