{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeApplications #-}
module Byron.Spec.Ledger.Util
( mkGoblinGens
) where
import Language.Haskell.TH
import System.FilePath ((</>), (<.>))
import Test.Goblin (loadGoblinDataFromFilePath)
loadGD :: String -> Q Exp
loadGD :: String -> Q Exp
loadGD String
pfName =
String -> Q Exp
loadGoblinDataFromFilePath String
relPath
where
relPath :: String
relPath = String
"src" String -> String -> String
</> String
"goblin_genomes" String -> String -> String
</> String
pfName String -> String -> String
<.> String
"genome"
mkGoblinGens :: String -> [String] -> Q [Dec]
mkGoblinGens :: String -> [String] -> Q [Dec]
mkGoblinGens String
stsNameStr [String]
pfNames = do
Bool
b <- Extension -> Q Bool
isExtEnabled Extension
TypeApplications
if Bool
b
then Q [Dec]
body
else String -> Q [Dec]
forall a. HasCallStack => String -> a
error String
"TypeApplications required"
where
body :: Q [Dec]
body :: Q [Dec]
body = do
[(Name, [Dec])]
pairs <- [Q (Name, [Dec])] -> Q [(Name, [Dec])]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence ((String -> Q (Name, [Dec])) -> [String] -> [Q (Name, [Dec])]
forall a b. (a -> b) -> [a] -> [b]
map (String -> String -> Q (Name, [Dec])
mkGoblinDecls String
stsNameStr) [String]
pfNames)
let goblinGenNames :: [Name]
goblinGenNames = ((Name, [Dec]) -> Name) -> [(Name, [Dec])] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map (Name, [Dec]) -> Name
forall a b. (a, b) -> a
fst [(Name, [Dec])]
pairs
goblinGenDecs :: [Dec]
goblinGenDecs = ((Name, [Dec]) -> [Dec]) -> [(Name, [Dec])] -> [Dec]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Name, [Dec]) -> [Dec]
forall a b. (a, b) -> b
snd [(Name, [Dec])]
pairs
let listName :: Name
listName = String -> Name
mkName (String
"goblinGens" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
stsNameStr)
listSigDec :: Dec
listSigDec = Name -> Type -> Dec
SigD Name
listName (Type -> Type -> Type
AppT Type
ListT Type
sigGenTy)
listDataDec :: Dec
listDataDec = Pat -> Body -> [Dec] -> Dec
ValD (Name -> Pat
VarP Name
listName)
(Exp -> Body
NormalB ([Exp] -> Exp
ListE ((Name -> Exp) -> [Name] -> [Exp]
forall a b. (a -> b) -> [a] -> [b]
map Name -> Exp
VarE [Name]
goblinGenNames)))
[]
[Dec] -> Q [Dec]
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Dec]
goblinGenDecs [Dec] -> [Dec] -> [Dec]
forall a. Semigroup a => a -> a -> a
<> [Dec
listSigDec, Dec
listDataDec])
stsName :: Name
stsName = String -> Name
mkName String
stsNameStr
sigGenTy :: Type
sigGenTy :: Type
sigGenTy = Type -> Type -> Type
AppT (Name -> Type
ConT (String -> Name
mkName String
"SignalGenerator"))
(Name -> Type
ConT Name
stsName)
mkGoblinDecls :: String -> String -> Q (Name, [Dec])
mkGoblinDecls :: String -> String -> Q (Name, [Dec])
mkGoblinDecls String
stsNameStr String
pfNameStr = do
[Dec]
decs <- [[Dec]] -> [Dec]
forall a. Monoid a => [a] -> a
mconcat ([[Dec]] -> [Dec]) -> Q [[Dec]] -> Q [Dec]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Q [Dec]] -> Q [[Dec]]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence [Q [Dec]
goblinDataDecs, Q [Dec]
goblinGenDecs]
(Name, [Dec]) -> Q (Name, [Dec])
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Name
ggName, [Dec]
decs)
where
genomeName :: String
genomeName = String
stsNameStr String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"_" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
pfNameStr
gdName :: Name
gdName = String -> Name
mkName (String
"goblinData_" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
genomeName)
ggName :: Name
ggName = String -> Name
mkName (String
"goblinGen_" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
genomeName)
stsName :: Name
stsName = String -> Name
mkName String
stsNameStr
goblinDataDecs :: Q [Dec]
goblinDataDecs = do
Exp
body <- String -> Q Exp
loadGD String
genomeName
let sigDec :: Dec
sigDec = Name -> Type -> Dec
SigD Name
gdName (Type -> Type -> Type
AppT (Name -> Type
ConT (String -> Name
mkName String
"GoblinData"))
(Name -> Type
ConT (String -> Name
mkName String
"Bool")))
let dataDec :: Dec
dataDec = Pat -> Body -> [Dec] -> Dec
ValD (Name -> Pat
VarP Name
gdName) (Exp -> Body
NormalB Exp
body) []
[Dec] -> Q [Dec]
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Dec
sigDec, Dec
dataDec]
goblinGenDecs :: Q [Dec]
goblinGenDecs = do
Exp
body <- [| tinkerWithSigGen @Bool @ $(pure (ConT stsName))
$(pure (VarE gdName)) |]
let sigDec :: Dec
sigDec = Name -> Type -> Dec
SigD Name
ggName (Type -> Type -> Type
AppT (Name -> Type
ConT (String -> Name
mkName String
"SignalGenerator"))
(Name -> Type
ConT Name
stsName))
let dataDec :: Dec
dataDec = Pat -> Body -> [Dec] -> Dec
ValD (Name -> Pat
VarP Name
ggName) (Exp -> Body
NormalB Exp
body) []
[Dec] -> Q [Dec]
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Dec
sigDec, Dec
dataDec]