{-# LANGUAGE CPP #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE DataKinds #-}
module Graph.Trace.Internal.TH
( makeInstancesForRep
, allRuntimeReps
) where
import Control.Monad
import Data.Traversable
import GHC.Exts
#if MIN_VERSION_ghc(9,0,0)
import GHC.Types (Multiplicity(..))
#endif
import Language.Haskell.TH
makeInstancesForRep :: Name -> Name -> Q Type -> Q [InstanceDec]
makeInstancesForRep :: Name -> Name -> Q Type -> Q [InstanceDec]
makeInstancesForRep Name
cls Name
meth Q Type
rep = do
let instTypes :: [Q Type]
instTypes =
#if MIN_VERSION_ghc(9,0,0)
[ conT cls `appT` rep `appT` [t| One |]
, conT cls `appT` rep `appT` [t| Many |]
]
#else
[ Name -> Q Type
conT Name
cls Q Type -> Q Type -> Q Type
`appT` Q Type
rep ]
#endif
[Q Type] -> (Q Type -> Q InstanceDec) -> Q [InstanceDec]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for [Q Type]
instTypes ((Q Type -> Q InstanceDec) -> Q [InstanceDec])
-> (Q Type -> Q InstanceDec) -> Q [InstanceDec]
forall a b. (a -> b) -> a -> b
$ \Q Type
instType -> do
Name
x <- String -> Q Name
newName String
"x"
CxtQ -> Q Type -> [Q InstanceDec] -> Q InstanceDec
instanceD ([Type] -> CxtQ
forall (f :: * -> *) a. Applicative f => a -> f a
pure []) Q Type
instType
[ Name -> [ClauseQ] -> Q InstanceDec
funD Name
meth [[PatQ] -> BodyQ -> [Q InstanceDec] -> ClauseQ
clause [Name -> PatQ
varP Name
x] (ExpQ -> BodyQ
normalB (ExpQ -> BodyQ) -> ExpQ -> BodyQ
forall a b. (a -> b) -> a -> b
$ Name -> ExpQ
varE Name
x) []] ]
runtimeReps :: [Q Type]
runtimeReps :: [Q Type]
runtimeReps =
[ [t| LiftedRep |]
, [t| UnliftedRep |]
, [t| IntRep |]
, [t| Int8Rep |]
, [t| Int16Rep |]
, [t| Int32Rep |]
, [t| Int64Rep |]
, [t| WordRep |]
, [t| Word8Rep |]
, [t| Word16Rep |]
, [t| Word32Rep |]
, [t| Word64Rep |]
, [t| AddrRep |]
, [t| FloatRep |]
, [t| DoubleRep |]
]
tupleReps :: [[Q Type]]
tupleReps :: [[Q Type]]
tupleReps = do
Int
len <- [Int
0..Int
2]
Int -> [Q Type] -> [[Q Type]]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM Int
len [Q Type]
runtimeReps
unboxedTupleReps :: [Q Type]
unboxedTupleReps :: [Q Type]
unboxedTupleReps = ([Q Type] -> Q Type) -> [[Q Type]] -> [Q Type]
forall a b. (a -> b) -> [a] -> [b]
map [Q Type] -> Q Type
forall (t :: * -> *). Traversable t => t (Q Type) -> Q Type
go [[Q Type]]
tupleReps where
go :: t (Q Type) -> Q Type
go t (Q Type)
tupleRep = do
t Type
tys <- t (Q Type) -> Q (t Type)
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence t (Q Type)
tupleRep
let list :: Type
list = (Type -> Type -> Type) -> Type -> t Type -> Type
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (Type -> Type -> Type
AppT (Type -> Type -> Type) -> (Type -> Type) -> Type -> Type -> Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Type -> Type -> Type
AppT Type
PromotedConsT) Type
PromotedNilT t Type
tys
Name -> Q Type
conT 'TupleRep Q Type -> Q Type -> Q Type
`appT` Type -> Q Type
forall (f :: * -> *) a. Applicative f => a -> f a
pure Type
list
unboxedSumReps :: [Q Type]
unboxedSumReps :: [Q Type]
unboxedSumReps = ([Q Type] -> Q Type) -> [[Q Type]] -> [Q Type]
forall a b. (a -> b) -> [a] -> [b]
map [Q Type] -> Q Type
forall (t :: * -> *). Traversable t => t (Q Type) -> Q Type
go [[Q Type]]
tupleReps where
go :: t (Q Type) -> Q Type
go t (Q Type)
tupleRep = do
t Type
tys <- t (Q Type) -> Q (t Type)
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence t (Q Type)
tupleRep
let list :: Type
list = (Type -> Type -> Type) -> Type -> t Type -> Type
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (Type -> Type -> Type
AppT (Type -> Type -> Type) -> (Type -> Type) -> Type -> Type -> Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Type -> Type -> Type
AppT Type
PromotedConsT) Type
PromotedNilT t Type
tys
Name -> Q Type
conT 'SumRep Q Type -> Q Type -> Q Type
`appT` Type -> Q Type
forall (f :: * -> *) a. Applicative f => a -> f a
pure Type
list
allRuntimeReps :: [Q Type]
allRuntimeReps :: [Q Type]
allRuntimeReps = [Q Type]
runtimeReps [Q Type] -> [Q Type] -> [Q Type]
forall a. Semigroup a => a -> a -> a
<> [Q Type]
unboxedTupleReps [Q Type] -> [Q Type] -> [Q Type]
forall a. Semigroup a => a -> a -> a
<> [Q Type]
unboxedSumReps