module Data.Algebra.TH
( deriveInstance
, deriveInstanceWith
, deriveInstanceWith_skipSignature
, deriveSignature
, SignatureTH(..)
, OperationTH(..)
, getSignatureInfo
, buildSignatureDataType
, signatureInstance
) where
import Data.Algebra.Internal
import Control.Applicative
import Control.Arrow ((***))
import Data.Foldable (Foldable(foldMap))
import Data.Traversable (Traversable)
import Data.Monoid (Endo(..))
import Language.Haskell.TH
import Data.Generics
data SignatureTH = SignatureTH
{ signatureName :: Name
, typeVarName :: Name
, operations :: [OperationTH]
}
data OperationTH = OperationTH
{ functionName :: Name
, operationName :: Name
, arity :: Int
, constructor :: Con
}
getSignatureInfo :: Name -> Q SignatureTH
getSignatureInfo name = do
ClassI (ClassD _ _ _ _ decs) _ <- reify name
let tv = mkName "a"
let sigName = changeName (++ "Signature") name
return
$ SignatureTH sigName tv
[ OperationTH nm opName ar (everywhere (mkT (rename tv' tv)) (mkCon opName))
| SigD nm (ForallT [PlainTV tv'] _ tp) <- decs
, Just (ar, mkCon) <- [buildOperation tv' tp]
, let opName = changeName ("Op_" ++) nm
]
deriveSignature :: Name -> Q [Dec]
deriveSignature className = do
mName <- lookupTypeName (nameBase className ++ "Signature")
s <- getSignatureInfo className
return $ if mName == Nothing then buildSignatureDataType s ++ signatureInstance className s else []
deriveInstance :: Q Type -> Q [Dec]
deriveInstance typ = deriveInstanceWith typ $ return []
deriveInstanceWith :: Q Type -> Q [Dec] -> Q [Dec]
deriveInstanceWith = deriveInstanceWith' True
deriveInstanceWith_skipSignature :: Q Type -> Q [Dec] -> Q [Dec]
deriveInstanceWith_skipSignature = deriveInstanceWith' False
deriveInstanceWith' :: Bool -> Q Type -> Q [Dec] -> Q [Dec]
deriveInstanceWith' addSignature qtyp dec = do
typ <- qtyp
case typ of
ForallT _ ctx (AppT (ConT className) typeName) ->
deriveInstanceWith'' addSignature ctx className typeName dec
AppT (ConT className) typeName ->
deriveInstanceWith'' addSignature [] className typeName dec
deriveInstanceWith'' :: Bool -> Cxt -> Name -> Type -> Q [Dec] -> Q [Dec]
deriveInstanceWith'' addSignature ctx className typeName dec = do
given <- dec
s <- getSignatureInfo className
let
givenLU =
[ (nameBase nm, (nm, renamer f)) | f@(FunD nm _) <- given ] ++
[ (nameBase nm, (nm, renamer v)) | v@(ValD (VarP nm) _ _) <- given ]
renamer = renameAll [ (nm, nm') | (b, (nm, _)) <- givenLU, OperationTH nm' _ _ _ <- operations s, nameBase nm' == b ]
impl =
[ maybe
(FunD fName [Clause (map VarP args) (NormalB (AppE (VarE 'algebra) (foldl (\e arg -> AppE e (VarE arg)) (ConE opName) args))) []])
snd mgiven
| OperationTH fName opName ar _ <- operations s, let mgiven = lookup (nameBase fName) givenLU, let args = mkArgList ar ]
(++ [InstanceD ctx (AppT (ConT className) typeName) impl]) <$>
if addSignature then deriveSignature className else return []
buildSignatureDataType :: SignatureTH -> [Dec]
buildSignatureDataType s =
let cons = [ con | OperationTH _ _ _ con <- operations s ]
in [DataD [] (signatureName s) [PlainTV (typeVarName s)] cons [''Functor, ''Foldable, ''Traversable, ''Show, ''Eq, ''Ord]]
signatureInstance :: Name -> SignatureTH -> [Dec]
signatureInstance nm s = [inst]
where
typeInst = TySynInstD ''Class [ConT (signatureName s)] (ConT nm)
clauses =
[ Clause [ConP opName (map VarP args)] (NormalB (foldl (\e arg -> AppE e (VarE arg)) (VarE fName) args)) []
| OperationTH fName opName ar _ <- operations s, let args = mkArgList ar ]
inst = InstanceD [] (AppT (ConT ''AlgebraSignature) (ConT (signatureName s))) [typeInst, FunD 'evaluate clauses]
buildOperation :: Name -> Type -> Maybe (Int, Name -> Con)
buildOperation nm (VarT nm') = if nm == nm' then Just (0, \opName -> NormalC opName []) else Nothing
buildOperation nm (AppT (AppT ArrowT h) t) = ((+1) *** fmap (prependC (NotStrict, h))) <$> buildOperation nm t
buildOperation _ _ = Nothing
changeName :: (String -> String) -> Name -> Name
changeName f = mkName . f . nameBase
mkArgList :: Int -> [Name]
mkArgList n = [ mkName $ "a" ++ show i | i <- [1 .. n] ]
renameAll :: Data a => [(Name, Name)] -> a -> a
renameAll m = everywhere (mkT (appEndo (foldMap (\(a, b) -> Endo $ rename a b) m)))
rename :: Name -> Name -> Name -> Name
rename a b c | a == c = b
rename _ _ t = t
prependC :: (Strict, Type) -> Con -> Con
prependC st (NormalC nm sts) = NormalC nm (st:sts)