{-# LANGUAGE CPP #-}
{-# LANGUAGE TemplateHaskell #-}
module Language.Syntactic.TH where
#if __GLASGOW_HASKELL__ < 710
import Control.Applicative
#endif
import Language.Haskell.TH
import Data.Hash (hashInt, combine)
import qualified Data.Hash as Hash
import Language.Syntactic
conName :: Con -> (Name, Int)
conName (NormalC name args) = (name, length args)
conName (RecC name args) = (name, length args)
conName (InfixC _ name _) = (name, 2)
conName (ForallC _ _ c) = conName c
#if __GLASGOW_HASKELL__ >= 800
conName (GadtC [n] as _) = (n, length as)
conName (RecGadtC [n] as _) = (n, length as)
#endif
data Method
= DefaultMethod Name Name
| MatchingMethod Name (Con -> Int -> Name -> Int -> Clause) [Clause]
deriveClass
:: Cxt
-> Name
-> Type
-> [Method]
-> DecsQ
deriveClass cxt ty clHead methods = do
Just cs <- viewDataDef <$> reify ty
return
[ instD cxt clHead $
[ FunD method (clauses ++ extra)
| MatchingMethod method mkClause extra <- methods
, let clauses = [ mkClause c i nm ar | (i,c) <- zip [0..] cs
, let (nm,ar) = conName c
]
] ++
[ FunD rhs [Clause [] (NormalB (VarE lhs)) []]
| DefaultMethod rhs lhs <- methods
]
]
deriveClassSimple
:: Name
-> Name
-> [Method]
-> DecsQ
deriveClassSimple cl ty = deriveClass [] ty (AppT (ConT cl) (ConT ty))
varSupply :: [Name]
varSupply = map mkName $ tail $ concat $ iterate step [[]]
where
step :: [String] -> [String]
step vars = concatMap (\c -> map (c:) vars) ['a' .. 'z']
deriveSymbol
:: Name
-> DecsQ
deriveSymbol ty =
deriveClassSimple ''Symbol ty [MatchingMethod 'symSig symSigClause []]
where
symSigClause _ _ con arity =
Clause [ConP con (replicate arity WildP)] (NormalB (VarE 'signature)) []
deriveEquality
:: Name
-> DecsQ
deriveEquality ty = do
Just cs <- viewDataDef <$> reify ty
let equalFallThrough = if length cs > 1
then [Clause [WildP, WildP] (NormalB $ ConE 'False) []]
else []
deriveClassSimple ''Equality ty
[ MatchingMethod 'equal equalClause equalFallThrough
, MatchingMethod 'hash hashClause []
]
where
equalClause _ _ con arity = Clause
[ ConP con [VarP v | v <- vs1]
, ConP con [VarP v | v <- vs2]
]
(NormalB body)
[]
where
vs1 = take arity varSupply
vs2 = take arity $ drop arity varSupply
body = case arity of
0 -> ConE 'True
_ -> AppE (VarE 'and)
( ListE
[ InfixE (Just (VarE v1)) (VarE '(==)) (Just (VarE v2))
| (v1,v2) <- zip vs1 vs2
]
)
hashClause _ i con arity = Clause
[ConP con [VarP v | v <- vs]]
(NormalB body)
[]
where
vs = take arity varSupply
body = case arity of
0 -> AppE (VarE 'hashInt) (LitE (IntegerL (toInteger i)))
_ -> foldl1 AppE
[ VarE 'foldr1
, VarE 'combine
, ListE
$ AppE (VarE 'hashInt) (LitE (IntegerL (toInteger i)))
: [ AppE (VarE 'Hash.hash) (VarE v)
| v <- vs
]
]
deriveRender
:: (String -> String)
-> Name
-> DecsQ
deriveRender modify ty =
deriveClassSimple ''Render ty [MatchingMethod 'renderSym renderClause []]
where
conName = modify . nameBase
renderClause _ _ con arity = Clause
[ConP con [VarP v | v <- take arity varSupply]]
(NormalB body)
[]
where
body = case arity of
0 -> LitE $ StringL $ conName con
_ -> renderRHS con $ take arity varSupply
renderRHS :: Name -> [Name] -> Exp
renderRHS con args =
AppE (VarE 'concat)
( ListE
[ LitE (StringL "(")
, AppE (VarE 'unwords)
(ListE (LitE (StringL (conName con)) : map showArg args))
, LitE (StringL ")")
]
)
showArg :: Name -> Exp
showArg arg = AppE (VarE 'show) (VarE arg)
instD
:: Cxt
-> Type
-> [Dec]
-> Dec
#if __GLASGOW_HASKELL__ >= 800
instD = InstanceD Nothing
#else
instD = InstanceD
#endif
viewDataDef :: Info -> Maybe [Con]
#if __GLASGOW_HASKELL__ >= 800
viewDataDef (TyConI (DataD _ _ _ _ cs _)) = Just cs
#else
viewDataDef (TyConI (DataD _ _ _ cs _)) = Just cs
#endif
viewDataDef _ = Nothing
eqPred :: Type -> Type -> Pred
#if __GLASGOW_HASKELL__ >= 710
eqPred t1 t2 = foldl1 AppT [EqualityT,t1,t2]
#else
eqPred = EqualP
#endif
classPred
:: Name
-> (Name -> Type)
-> [Type]
-> Pred
#if __GLASGOW_HASKELL__ >= 710
classPred cl con = foldl AppT (con cl)
#else
classPred cl con = ClassP cl
#endif
tySynInst :: Name -> [Type] -> Type -> Dec
#if __GLASGOW_HASKELL__ >= 708
tySynInst t as rhs = TySynInstD t (TySynEqn as rhs)
#else
tySynInst = TySynInstD
#endif