module Homoiconic.Homogeneous.TH
where
import Prelude
import Control.Monad
import Data.List
import Data.Foldable
import Data.Typeable
import Data.Kind
import GHC.Exts hiding (IsList(..))
import Homoiconic.Common.TH
import Language.Haskell.TH hiding (Type)
import qualified Language.Haskell.TH as TH
mkFAlgebra :: Name -> Q [Dec]
mkFAlgebra algName = do
qinfo <- reify algName
rawdecs <- case qinfo of
ClassI (ClassD cxt _ [_] _ decs) _ -> return decs
_ -> error $ "mkFAlgebra called on "
++show algName
++", which is not a class of kind `Type -> Constraint`"
let go x = case x of
SigD _ sigType -> if not $ isVarT $ getReturnType sigType
then False
else True
let decs = filter go rawdecs
let varName = mkName "a"
parentClasses <- listParentClasses algName
superClasses <- listSuperClasses algName
superClassesWithParents <- listSuperClassesWithParents algName
let instFAlgebra = InstanceD
Nothing
[]
( AppT
( ConT $ mkName "FAlgebra" )
( ConT $ algName)
)
[ DataInstD
[]
( mkName "Sig" )
[ ConT algName, VarT varName ]
Nothing
(
[ NormalC
( mkName $ "Sig_" ++ renameClassMethod sigName )
( map
(Bang NoSourceUnpackedness NoSourceStrictness,)
(getArgs $ subForall varName sigType) )
| SigD sigName sigType <- decs
]
++
[ NormalC
( mkName $ "Sig_"++nameBase algName++"_"++nameBase parentClass)
[ ( Bang NoSourceUnpackedness SourceStrict
, AppT
( AppT
( ConT $ mkName "Sig" )
( ConT parentClass )
)
( VarT varName )
)
]
| parentClass <- parentClasses
]
)
[]
, FunD
( mkName "runSig" )
(
[ Clause
[ ConP
( mkName $ "Sig_" ++ renameClassMethod sigName )
( map VarP $ genericArgs sigType )
]
( NormalB $ foldl AppE
( VarE sigName )
( map VarE $ genericArgs sigType )
)
[]
| SigD sigName sigType <- decs
]
++
[ Clause
[ ConP
( mkName $ "Sig_"++nameBase algName++"_"++nameBase parentClass )
[ VarP $ mkName $ "s" ]
]
( NormalB $ AppE
( VarE $ mkName "runSig" )
( VarE $ mkName "s" )
)
[]
| parentClass <- parentClasses
]
++
[ Clause
[ VarP $ mkName "_" ]
( NormalB $ AppE
( VarE $ mkName "error" )
( LitE $ StringL $ "runSig called on "++nameBase algName++" which has no homogeneous class methods" )
)
[]
]
)
, TySynInstD
( mkName $ "ParentClasses" )
( TySynEqn
[ ConT $ algName ]
( foldl (\b a -> AppT (AppT PromotedConsT (ConT a)) b) PromotedNilT parentClasses )
)
]
let instEqSig = StandaloneDerivD
[ AppT
( ConT $ mkName "Eq" )
( VarT $ mkName "a" )
]
( AppT
( ConT $ mkName "Eq" )
( AppT
( AppT
( ConT $ mkName "Sig" )
( ConT $ algName )
)
( VarT $ mkName "a" )
)
)
let instFunctor = InstanceD
Nothing
[]
( AppT
( ConT $ mkName "Functor")
( AppT
( ConT $ mkName "Sig" )
( ConT $ algName )
)
)
[ FunD
( mkName "fmap" )
(
[ Clause
[ VarP $ mkName "f"
, ConP
( mkName $ "Sig_" ++ renameClassMethod sigName )
( map VarP $ genericArgs sigType )
]
( NormalB $ foldl AppE (ConE (mkName $ "Sig_" ++ renameClassMethod sigName))
[ if isVarT argType
then AppE
( VarE $ mkName "f" )
( VarE $ argName )
else VarE argName
| (argName,argType) <- zip (genericArgs sigType) (getArgs sigType)
]
)
[]
| SigD sigName sigType <- decs
]
++
[ Clause
[ VarP $ mkName "f"
, ConP
( mkName $ "Sig_"++nameBase algName++"_"++nameBase parentClass )
[ VarP $ mkName "s" ]
]
( NormalB $ AppE
( ConE $ mkName $ "Sig_"++nameBase algName++"_"++nameBase parentClass )
( AppE
( AppE
( VarE $ mkName "fmap" )
( VarE $ mkName "f" )
)
( VarE $ mkName "s" )
)
)
[]
| parentClass <- parentClasses
]
++
[ Clause
[ VarP $ mkName "f", VarP $ mkName "a" ]
( NormalB $ AppE
( VarE $ mkName "error" )
( LitE $ StringL $ "fmap called on Sig "++nameBase algName++" which has no homogeneous class methods" )
)
[]
]
)
]
let instFoldable = InstanceD
Nothing
[]
( AppT
( ConT $ mkName "Foldable" )
( AppT
( ConT $ mkName "Sig" )
( ConT algName )
)
)
[ FunD
( mkName "foldr" )
(
[ Clause
[ VarP $ mkName "f"
, VarP $ mkName "b"
, ConP
( mkName $ "Sig_" ++ renameClassMethod sigName )
( map VarP $ genericArgs sigType )
]
( NormalB $ foldl
(\a b -> AppE
( AppE
( VarE $ mkName "f" )
b
)
a
)
( VarE $ mkName "b" )
( reverse
$ map (VarE . fst)
$ filter (isVarT . snd)
$ zip (genericArgs sigType) (getArgs sigType)
)
)
[]
| SigD sigName sigType <- decs
]
++
[ Clause
[ VarP $ mkName "f"
, VarP $ mkName "b"
, ConP
( mkName $ "Sig_"++nameBase algName++"_"++nameBase parentClass )
[ VarP $ mkName "s" ]
]
( NormalB $ AppE
( AppE
( AppE
( VarE $ mkName "foldr" )
( VarE $ mkName "f" )
)
( VarE $ mkName "b" )
)
( VarE $ mkName "s" )
)
[]
| parentClass <- parentClasses
]
++
[ Clause
[ VarP $ mkName "f", VarP $ mkName "b", VarP $ mkName "ta" ]
( NormalB $ AppE
( VarE $ mkName "error" )
( LitE $ StringL $ "foldr called on Sig "++nameBase algName++" which has no homogeneous class methods" )
)
[]
]
)
]
let instShow = InstanceD
Nothing
[ AppT
( ConT $ mkName "Show" )
( VarT varName )
]
( AppT
( ConT $ mkName "Show" )
( AppT
( AppT
( ConT $ mkName "Sig" )
( ConT algName )
)
( VarT $ varName )
)
)
[ FunD
( mkName "show" )
(
[ Clause
[ ConP
( mkName $ "Sig_"++nameBase algName++"_"++nameBase parentClass)
[ VarP $ mkName "s" ]
]
( NormalB $ AppE
( VarE $ mkName "show" )
( VarE $ mkName "s" )
)
[]
| parentClass <- parentClasses
]
++
[ Clause
[ ConP
( mkName $ "Sig_" ++ renameClassMethod sigName )
( map VarP $ genericArgs sigType )
]
( if isOperator (nameBase sigName)
then NormalB $ AppE
( AppE
( VarE $ mkName "++" )
( AppE
( AppE
( VarE $ mkName "++" )
( AppE
( VarE $ mkName "show" )
( VarE $ mkName "a0" )
)
)
( LitE $ StringL $ nameBase sigName )
)
)
( AppE
( VarE $ mkName "show" )
( VarE $ mkName "a1" )
)
else NormalB $ foldl
( \b a -> AppE
( AppE
( VarE $ mkName "++" )
( AppE
( AppE
( VarE $ mkName "++" )
b
)
( LitE $ StringL " " )
)
)
( AppE
( VarE $ mkName "show" )
a
)
)
( LitE $ StringL $ nameBase sigName )
( map VarE $ genericArgs sigType )
)
[]
| SigD sigName sigType <- decs
]
++
[ Clause
[ VarP $ mkName "f" ]
( NormalB $ AppE
( VarE $ mkName "error" )
( LitE $ StringL $ "show called on Sig "++nameBase algName++" which has no homogeneous class methods" )
)
[]
]
)
]
let algName' = mkName "alg'"
let instHomFree = InstanceD
Nothing
(
( if nameBase algName=="Ord" || nameBase algName=="FloatingOrd"
then
[ AppT
( ConT $ mkName "Eq" )
( VarT $ varName )
, AppT
( ConT $ mkName "Eq" )
( AppT
( AppT
( ConT $ mkName "Sig" )
( VarT $ mkName "alg'" )
)
( AppT
( AppT
( ConT $ mkName "Free" )
( AppT
( ConT $ mkName "Sig" )
( VarT $ mkName "alg'" )
)
)
( VarT $ mkName "a" )
)
)
]
else []
)
++
[ AppT
( AppT
( ConT $ mkName "View" )
( ConT n )
)
( VarT algName' )
| n <- algName:superClasses
]
)
( AppT
( ConT algName )
( AppT
( AppT
( ConT $ mkName "Free" )
( AppT
( ConT $ mkName "Sig" )
( VarT algName' )
)
)
( VarT varName )
)
)
[ FunD
sigName
[ Clause
( map VarP $ genericArgs sigType )
( NormalB $ AppE
( ConE $ mkName "Free" )
( AppE
( VarE $ mkName "embedSig" )
( foldl AppE
( ConE $ mkName $ "Sig_"++renameClassMethod sigName )
( map VarE $ genericArgs sigType )
)
)
)
[]
]
| SigD sigName sigType <- decs
]
let instHomViews =
[ InstanceD
Nothing
[]
( AppT
( AppT
( ConT $ mkName "View" )
( ConT superClass )
)
( ConT algName )
)
[ FunD
( mkName "embedSig" )
[ Clause
[]
( NormalB $ ConE $ mkName $ "Sig_"++nameBase algName++"_"++nameBase superClass )
[]
]
, FunD
( mkName "unsafeExtractSig" )
[ Clause
[ ConP
( mkName $ "Sig_"++nameBase algName++"_"++nameBase superClass )
[ VarP $ mkName "s" ]
]
( NormalB $ VarE $ mkName "s" )
[]
]
]
| superClass <- parentClasses
]
++
[ InstanceD
Nothing
[]
( AppT
( AppT
( ConT $ mkName "View" )
( ConT superClass )
)
( ConT algName )
)
[ FunD
( mkName "embedSig" )
[ Clause
[ VarP $ mkName "s" ]
( NormalB $ AppE
( ConE $ mkName $ "Sig_"++nameBase algName++"_"++nameBase parentClass )
( AppE
( VarE $ mkName "embedSig" )
( VarE $ mkName "s" )
)
)
[]
]
, FunD
( mkName "unsafeExtractSig" )
[ Clause
[ ConP
( mkName $ "Sig_"++nameBase algName++"_"++nameBase parentClass )
[ VarP $ mkName "s" ]
]
( NormalB $ AppE
( VarE $ mkName "unsafeExtractSig" )
( VarE $ mkName "s" )
)
[]
]
]
| (parentClass,superClass) <- superClassesWithParents
]
let patSyns =
#if __GHC__GLASGOW__ < 801
[]
#else
[ PatSynD
( mkName $ "AST_" ++ renameClassMethod sigName )
( PrefixPatSyn $ genericArgs sigType )
( ExplBidir
[ Clause
( map VarP $ genericArgs sigType )
( NormalB $ AppE
( ConE $ mkName "Free" )
( AppE
( VarE $ mkName "embedSig" )
( foldl
AppE
( ConE $ mkName $ "Sig_" ++ renameClassMethod sigName )
( map VarE $ genericArgs sigType )
)
)
)
[]
]
)
( ConP
( mkName "Free" )
[ ViewP
( VarE $ mkName "unsafeExtractSig" )
( ConP
( mkName $ "Sig_" ++ renameClassMethod sigName )
( map VarP $ genericArgs sigType )
)
]
)
| SigD sigName sigType <- decs
]
#endif
return $ [instFAlgebra,instEqSig,instFunctor,instFoldable,instShow,instHomFree] ++ instHomViews ++ patSyns