{-# 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
  -- data files we get at compile time are always relative to the project
  relPath :: String
relPath = String
"src" String -> String -> String
</> String
"goblin_genomes" String -> String -> String
</> String
pfName String -> String -> String
<.> String
"genome"

-- | Take a name (e.g. "DELEG") and a list of `PredicateFailure`s in `renderPF`
-- form (see repo goblins-sts-breeder; STSExtra typeclass) (e.g.
-- ["UTXOW_InsufficientWitnesses"]) and returns `n+1` declarations, where n
-- is the length of the `pfNames` list. There will be 1 decl per element of
-- `pfNames`, which wraps a goblin mutation around the valid `SignalGenerator`.
-- The final decl is a toplevel list of the previously defined `SignalGenerator`s.
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)

-- | Makes a top-level `Dec` for the GoblinData (loaded at TH evaluation time
-- from a file) and another top-level `Dec` for an invalid generator using the
-- GoblinData declaration.
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]