{-# LANGUAGE TemplateHaskell #-}
module Data.Comp.Trans (
CompTrans
, runCompTrans
, withSubstitutions
, getTypeParamVars
, withExcludedNames
, standardExcludedNames
, withAnnotationProp
, defaultPropAnn
, defaultUnpropAnn
, deriveMultiComp
, generateNameLists
, makeSumType
, T.deriveTrans
, U.deriveUntrans
, getLabels
) where
import Control.Monad ( liftM )
import Control.Monad.Trans ( lift )
import Data.Data ( Data )
import Language.Haskell.TH.Quote ( dataToExpQ )
import Language.Haskell.TH
import qualified Data.Comp.Trans.DeriveTrans as T
import qualified Data.Comp.Trans.DeriveUntrans as U
import Data.Comp.Trans.DeriveMulti
import Data.Comp.Trans.Collect
import Data.Comp.Trans.Util as Util
deriveMultiComp :: Name -> CompTrans [Dec]
deriveMultiComp :: Name -> CompTrans [Dec]
deriveMultiComp root :: Name
root = do [Name]
descs <- Name -> CompTrans [Name]
collectTypes Name
root
[Name] -> CompTrans [Dec] -> CompTrans [Dec]
forall a. [Name] -> CompTrans a -> CompTrans a
withAllTypes [Name]
descs (CompTrans [Dec] -> CompTrans [Dec])
-> CompTrans [Dec] -> CompTrans [Dec]
forall a b. (a -> b) -> a -> b
$ ([[Dec]] -> [Dec]) -> CompTrans [[Dec]] -> CompTrans [Dec]
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM [[Dec]] -> [Dec]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (CompTrans [[Dec]] -> CompTrans [Dec])
-> CompTrans [[Dec]] -> CompTrans [Dec]
forall a b. (a -> b) -> a -> b
$ (Name -> CompTrans [Dec]) -> [Name] -> CompTrans [[Dec]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Name -> CompTrans [Dec]
deriveMulti [Name]
descs
generateNameLists :: Name -> CompTrans [Dec]
generateNameLists :: Name -> CompTrans [Dec]
generateNameLists root :: Name
root = do
[Name]
descs <- Name -> CompTrans [Name]
collectTypes Name
root
[Dec]
nameList1 <- ReaderT TransCtx Q [Dec] -> CompTrans [Dec]
forall a. ReaderT TransCtx Q a -> CompTrans a
CompTrans (ReaderT TransCtx Q [Dec] -> CompTrans [Dec])
-> ReaderT TransCtx Q [Dec] -> CompTrans [Dec]
forall a b. (a -> b) -> a -> b
$ Q [Dec] -> ReaderT TransCtx Q [Dec]
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Q [Dec] -> ReaderT TransCtx Q [Dec])
-> Q [Dec] -> ReaderT TransCtx Q [Dec]
forall a b. (a -> b) -> a -> b
$ Name -> Name -> [Name] -> Q [Dec]
forall t. Data t => Name -> Name -> [t] -> Q [Dec]
mkList ''Name (String -> Name
mkName "origASTTypes") [Name]
descs
[Dec]
nameList2 <- ReaderT TransCtx Q [Dec] -> CompTrans [Dec]
forall a. ReaderT TransCtx Q a -> CompTrans a
CompTrans (ReaderT TransCtx Q [Dec] -> CompTrans [Dec])
-> ReaderT TransCtx Q [Dec] -> CompTrans [Dec]
forall a b. (a -> b) -> a -> b
$ Q [Dec] -> ReaderT TransCtx Q [Dec]
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Q [Dec] -> ReaderT TransCtx Q [Dec])
-> Q [Dec] -> ReaderT TransCtx Q [Dec]
forall a b. (a -> b) -> a -> b
$ Name -> Name -> [Name] -> Q [Dec]
forall t. Data t => Name -> Name -> [t] -> Q [Dec]
mkList ''Name (String -> Name
mkName "newASTTypes") ((Name -> Name) -> [Name] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map Name -> Name
transName [Name]
descs)
[Dec] -> CompTrans [Dec]
forall (m :: * -> *) a. Monad m => a -> m a
return ([Dec] -> CompTrans [Dec]) -> [Dec] -> CompTrans [Dec]
forall a b. (a -> b) -> a -> b
$ [Dec]
nameList1 [Dec] -> [Dec] -> [Dec]
forall a. [a] -> [a] -> [a]
++ [Dec]
nameList2
where
mkList :: Data t => Name -> Name -> [t] -> Q [Dec]
mkList :: Name -> Name -> [t] -> Q [Dec]
mkList tNm :: Name
tNm name :: Name
name contents :: [t]
contents = [Q Dec] -> Q [Dec]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence [ Name -> TypeQ -> Q Dec
sigD Name
name (TypeQ -> TypeQ -> TypeQ
appT TypeQ
listT (Name -> TypeQ
conT Name
tNm))
, PatQ -> BodyQ -> [Q Dec] -> Q Dec
valD (Name -> PatQ
varP Name
name) (ExpQ -> BodyQ
normalB ExpQ
namesExp) []
]
where
namesExp :: ExpQ
namesExp = (forall b. Data b => b -> Maybe ExpQ) -> [t] -> ExpQ
forall a.
Data a =>
(forall b. Data b => b -> Maybe ExpQ) -> a -> ExpQ
dataToExpQ (Maybe ExpQ -> b -> Maybe ExpQ
forall a b. a -> b -> a
const Maybe ExpQ
forall a. Maybe a
Nothing) [t]
contents
getLabels :: [Name] -> CompTrans [Type]
getLabels :: [Name] -> CompTrans [Type]
getLabels nms :: [Name]
nms = (Name -> CompTrans Type) -> [Name] -> CompTrans [Type]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Name -> CompTrans Type
toLabel [Name]
nms
where
toLabel :: Name -> CompTrans Type
toLabel n :: Name
n = do
TyConI (DataD _ n' :: Name
n' _ _ _ _) <- ReaderT TransCtx Q Info -> CompTrans Info
forall a. ReaderT TransCtx Q a -> CompTrans a
CompTrans (ReaderT TransCtx Q Info -> CompTrans Info)
-> ReaderT TransCtx Q Info -> CompTrans Info
forall a b. (a -> b) -> a -> b
$ Q Info -> ReaderT TransCtx Q Info
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Q Info -> ReaderT TransCtx Q Info)
-> Q Info -> ReaderT TransCtx Q Info
forall a b. (a -> b) -> a -> b
$ Name -> Q Info
reify (Name -> Q Info) -> Name -> Q Info
forall a b. (a -> b) -> a -> b
$ Name -> Name
nameLab Name
n
Type -> CompTrans Type
forall (m :: * -> *) a. Monad m => a -> m a
return (Type -> CompTrans Type) -> Type -> CompTrans Type
forall a b. (a -> b) -> a -> b
$ Name -> Type
ConT Name
n'
getTypeParamVars :: [Name] -> CompTrans [Name]
getTypeParamVars :: [Name] -> CompTrans [Name]
getTypeParamVars = ([[Name]] -> [Name]) -> CompTrans [[Name]] -> CompTrans [Name]
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM [[Name]] -> [Name]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (CompTrans [[Name]] -> CompTrans [Name])
-> ([Name] -> CompTrans [[Name]]) -> [Name] -> CompTrans [Name]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Name -> CompTrans [Name]) -> [Name] -> CompTrans [[Name]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Name -> CompTrans [Name]
getTypeArgs
makeSumType :: String -> [Name] -> CompTrans [Dec]
makeSumType :: String -> [Name] -> CompTrans [Dec]
makeSumType nm :: String
nm types :: [Name]
types = ReaderT TransCtx Q [Dec] -> CompTrans [Dec]
forall a. ReaderT TransCtx Q a -> CompTrans a
CompTrans (ReaderT TransCtx Q [Dec] -> CompTrans [Dec])
-> ReaderT TransCtx Q [Dec] -> CompTrans [Dec]
forall a b. (a -> b) -> a -> b
$ Q [Dec] -> ReaderT TransCtx Q [Dec]
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Q [Dec] -> ReaderT TransCtx Q [Dec])
-> Q [Dec] -> ReaderT TransCtx Q [Dec]
forall a b. (a -> b) -> a -> b
$ [Q Dec] -> Q [Dec]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence ([Q Dec] -> Q [Dec]) -> [Q Dec] -> Q [Dec]
forall a b. (a -> b) -> a -> b
$ [Name -> [TyVarBndr] -> TypeQ -> Q Dec
tySynD (String -> Name
mkName String
nm) [] (TypeQ -> Q Dec) -> TypeQ -> Q Dec
forall a b. (a -> b) -> a -> b
$ [Name] -> TypeQ
sumType [Name]
types]
where
sumType :: [Name] -> TypeQ
sumType [] = String -> TypeQ
forall (m :: * -> *) a. MonadFail m => String -> m a
fail "Attempting to make empty sum type"
sumType ts :: [Name]
ts = (Name -> TypeQ -> TypeQ) -> TypeQ -> [Name] -> TypeQ
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\a :: Name
a acc :: TypeQ
acc -> TypeQ
promotedConsT TypeQ -> TypeQ -> TypeQ
`appT` Name -> TypeQ
conT Name
a TypeQ -> TypeQ -> TypeQ
`appT` TypeQ
acc) TypeQ
promotedNilT [Name]
ts