{-# 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

-- | A splice for generating instances for a given RuntimeRep
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 to generate instances for
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

-- Does not include SIMD vectors b/c they are platform dependent
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