{-# LANGUAGE TemplateHaskell #-}
module Test.Goblin.TH
( deriveGoblin
, deriveAddShrinks
, deriveSeedGoblin
) where
import Control.Monad (foldM, forM)
import Data.Typeable (Typeable)
import Language.Haskell.TH
import TH.ReifySimple
import Test.Goblin.Core
deriveGoblin :: Name -> Q [Dec]
deriveGoblin :: Name -> Q [Dec]
deriveGoblin Name
name = do
(DataType Name
_dName [Name]
dTyVars Cxt
_dCtx [DataCon]
dCons) <- Name -> Q DataType
reifyDataType Name
name
Type
genomeVar <- Name -> Type
VarT (Name -> Type) -> Q Name -> Q Type
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> Q Name
newName String
"genome"
[Name]
classParamNames <- [Name] -> (Name -> Q Name) -> Q [Name]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [Name]
dTyVars (Q Name -> Name -> Q Name
forall a b. a -> b -> a
const (String -> Q Name
newName String
"arg"))
let con :: DataCon
con = [DataCon] -> DataCon
forall p. [p] -> p
ensureSingleton [DataCon]
dCons
Cxt
ctx <- if [Name] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Name]
classParamNames
then (Type -> Cxt -> Cxt
forall a. a -> [a] -> [a]
:[]) (Type -> Cxt) -> Q Type -> Q Cxt
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [t| GeneOps $(pure genomeVar) |]
else Type -> [Name] -> Q Cxt
forall (t :: * -> *). Foldable t => Type -> t Name -> Q Cxt
wrapWithGoblinConstraints Type
genomeVar [Name]
classParamNames
Type
decTy <- Type -> [Name] -> Q Type
forall (t :: * -> *). Foldable t => Type -> t Name -> Q Type
makeInstanceType Type
genomeVar [Name]
classParamNames
Dec
tink <- DataCon -> Q Dec
makeTinker DataCon
con
Dec
conj <- DataCon -> Q Dec
makeConjure DataCon
con
[Dec] -> Q [Dec]
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Maybe Overlap -> Cxt -> Type -> [Dec] -> Dec
InstanceD Maybe Overlap
forall a. Maybe a
Nothing Cxt
ctx Type
decTy [Dec
tink, Dec
conj]]
where
ensureSingleton :: [p] -> p
ensureSingleton [p]
dCons =
case [p]
dCons of
[] -> String -> p
forall a. HasCallStack => String -> a
error String
"deriveGoblin: cannot derive Goblin for a void type"
[p
x] -> p
x
[p]
_ -> String -> p
forall a. HasCallStack => String -> a
error String
"deriveGoblin: cannot derive Goblin for a sum type"
wrapWithGoblinConstraints :: Type -> t Name -> Q Cxt
wrapWithGoblinConstraints Type
genomeVar = [Q Type] -> Q Cxt
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence ([Q Type] -> Q Cxt) -> (t Name -> [Q Type]) -> t Name -> Q Cxt
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
(Name -> [Q Type]) -> t Name -> [Q Type]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (\Name
cpn -> [ [t| Goblin $(pure genomeVar) $(pure (VarT cpn)) |]
, [t| AddShrinks $(pure (VarT cpn)) |]
])
makeInstanceType :: Type -> t Name -> Q Type
makeInstanceType Type
genomeVar t Name
classParamNames =
[t| Goblin $(pure genomeVar)
( $(pure (foldl wrapTyVars (ConT name) classParamNames)) ) |]
wrapTyVars :: Type -> Name -> Type
wrapTyVars Type
acc Name
cpn = Type -> Type -> Type
AppT Type
acc (Name -> Type
VarT Name
cpn)
makeTinker :: DataCon -> Q Dec
makeTinker DataCon
con = do
if [(Maybe Name, Type)] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (DataCon -> [(Maybe Name, Type)]
dcFields DataCon
con) Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
0
then String -> Q Dec
mkPureDec String
"tinker"
else do
Name
argName <- String -> Q Name
newName String
"arg"
let pat :: Pat
pat = Name -> Pat
VarP Name
argName
Exp
body <- Name -> Q Exp
mkBody Name
argName
Dec -> Q Dec
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Name -> [Clause] -> Dec
FunD (String -> Name
mkName String
"tinker") [[Pat] -> Body -> [Dec] -> Clause
Clause [Pat
pat] (Exp -> Body
NormalB Exp
body) []])
where
mkBody :: Name -> Q Exp
mkBody Name
argName = do
[Name]
fieldNames <- [(Maybe Name, Type)] -> ((Maybe Name, Type) -> Q Name) -> Q [Name]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM (DataCon -> [(Maybe Name, Type)]
dcFields DataCon
con) (Q Name -> (Maybe Name, Type) -> Q Name
forall a b. a -> b -> a
const (String -> Q Name
newName String
"field"))
let accessors :: [Exp]
accessors = Name -> [Name] -> [Exp]
makeAccessors (DataCon -> Name
dcName DataCon
con) [Name]
fieldNames
Exp
start <- [| $(pure (makeConPacker (dcName con) fieldNames))
<$$> (tinker ($(pure (head accessors))
<$> $(pure (VarE argName)))) |]
let tinkerBody :: Q Exp
tinkerBody =
(Exp -> Exp -> Q Exp) -> Exp -> [Exp] -> Q Exp
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM (\Exp
acc Exp
getter -> [| $(pure acc)
<**> (tinker ($(pure getter)
<$> $(pure (VarE argName)))) |])
Exp
start
([Exp] -> [Exp]
forall a. [a] -> [a]
tail [Exp]
accessors)
[| tinkerRummagedOrConjureOrSave $(tinkerBody) |]
makeConjure :: DataCon -> Q Dec
makeConjure DataCon
con = do
if [(Maybe Name, Type)] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (DataCon -> [(Maybe Name, Type)]
dcFields DataCon
con) Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
0
then Q Dec
mkNullaryDefn
else do
Exp
start <- [| $(pure (ConE (dcName con))) <$> conjure |]
Exp
body <- (Exp -> (Maybe Name, Type) -> Q Exp)
-> Exp -> [(Maybe Name, Type)] -> Q Exp
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM (\Exp
acc (Maybe Name, Type)
_ -> [| $(pure acc) <*> conjure |])
Exp
start
([(Maybe Name, Type)] -> [(Maybe Name, Type)]
forall a. [a] -> [a]
tail (DataCon -> [(Maybe Name, Type)]
dcFields DataCon
con))
Exp
cb <- [| saveInBagOfTricks =<< $(pure body) |]
Dec -> Q Dec
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Name -> [Clause] -> Dec
FunD (String -> Name
mkName String
"conjure") [[Pat] -> Body -> [Dec] -> Clause
Clause [] (Exp -> Body
NormalB Exp
cb) []])
where
mkNullaryDefn :: Q Dec
mkNullaryDefn = do
Exp
body <- [| pure $(pure (ConE (dcName con))) |]
Dec -> Q Dec
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Name -> [Clause] -> Dec
FunD (String -> Name
mkName String
"conjure") [[Pat] -> Body -> [Dec] -> Clause
Clause [] (Exp -> Body
NormalB Exp
body) []])
deriveAddShrinks :: Name -> Q [Dec]
deriveAddShrinks :: Name -> Q [Dec]
deriveAddShrinks Name
name = do
(DataType Name
_dName [Name]
dTyVars Cxt
_dCtx [DataCon]
dCons) <- Name -> Q DataType
reifyDataType Name
name
[Name]
classParamNames <- [Name] -> (Name -> Q Name) -> Q [Name]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [Name]
dTyVars (Q Name -> Name -> Q Name
forall a b. a -> b -> a
const (String -> Q Name
newName String
"arg"))
Cxt
ctx <- [Name] -> Q Cxt
wrapWithConstraints [Name]
classParamNames
Type
decTy <- [Name] -> Q Type
forall (t :: * -> *). Foldable t => t Name -> Q Type
makeInstanceType [Name]
classParamNames
Dec
addShrinkDec <- [DataCon] -> Q Dec
makeAddShrinks [DataCon]
dCons
[Dec] -> Q [Dec]
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Maybe Overlap -> Cxt -> Type -> [Dec] -> Dec
InstanceD Maybe Overlap
forall a. Maybe a
Nothing Cxt
ctx Type
decTy [Dec
addShrinkDec]]
where
wrapWithConstraints :: [Name] -> Q Cxt
wrapWithConstraints = [Q Type] -> Q Cxt
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence ([Q Type] -> Q Cxt) -> ([Name] -> [Q Type]) -> [Name] -> Q Cxt
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
(Name -> Q Type) -> [Name] -> [Q Type]
forall a b. (a -> b) -> [a] -> [b]
map (\Name
cpn -> [t| AddShrinks $(pure (VarT cpn)) |])
makeInstanceType :: t Name -> Q Type
makeInstanceType t Name
classParamNames =
[t| AddShrinks
( $(pure (foldl wrapTyVars (ConT name) classParamNames)) ) |]
wrapTyVars :: Type -> Name -> Type
wrapTyVars Type
acc Name
cpn = Type -> Type -> Type
AppT Type
acc (Name -> Type
VarT Name
cpn)
makeAddShrinks :: [DataCon] -> Q Dec
makeAddShrinks :: [DataCon] -> Q Dec
makeAddShrinks [DataCon]
dcs = do
[Clause]
clauses <- (DataCon -> Q Clause) -> [DataCon] -> Q [Clause]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM DataCon -> Q Clause
makeAddShrinksClause [DataCon]
dcs
Dec -> Q Dec
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Name -> [Clause] -> Dec
FunD (String -> Name
mkName String
"addShrinks") [Clause]
clauses)
makeAddShrinksClause :: DataCon -> Q Clause
makeAddShrinksClause :: DataCon -> Q Clause
makeAddShrinksClause DataCon
con =
if [(Maybe Name, Type)] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (DataCon -> [(Maybe Name, Type)]
dcFields DataCon
con) Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
0
then do
Name
field <- String -> Q Name
newName String
"field"
Exp
body <- [| pure $(pure (VarE field)) |]
Clause -> Q Clause
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Pat] -> Body -> [Dec] -> Clause
Clause [Name -> Pat
VarP Name
field] (Exp -> Body
NormalB Exp
body) [])
else do
[Name]
fieldNames <- [(Maybe Name, Type)] -> ((Maybe Name, Type) -> Q Name) -> Q [Name]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM (DataCon -> [(Maybe Name, Type)]
dcFields DataCon
con) (Q Name -> (Maybe Name, Type) -> Q Name
forall a b. a -> b -> a
const (String -> Q Name
newName String
"field"))
let pat :: Pat
pat = Name -> [Pat] -> Pat
ConP (DataCon -> Name
dcName DataCon
con) ((Name -> Pat) -> [Name] -> [Pat]
forall a b. (a -> b) -> [a] -> [b]
map Name -> Pat
VarP [Name]
fieldNames)
Exp
start <- [| $(pure (makeConPacker (dcName con) fieldNames))
<$> addShrinks $(pure (VarE (head fieldNames))) |]
Exp
body <- (Exp -> Name -> Q Exp) -> Exp -> [Name] -> Q Exp
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM (\Exp
acc Name
v -> [| $(pure acc) <*> addShrinks $(pure (VarE v)) |])
Exp
start
([Name] -> [Name]
forall a. [a] -> [a]
tail ([Name]
fieldNames))
Clause -> Q Clause
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Pat] -> Body -> [Dec] -> Clause
Clause [Pat
pat] (Exp -> Body
NormalB Exp
body) [])
deriveSeedGoblin :: Name -> Q [Dec]
deriveSeedGoblin :: Name -> Q [Dec]
deriveSeedGoblin Name
name = do
(DataType Name
_dName [Name]
dTyVars Cxt
_dCtx [DataCon]
dCons) <- Name -> Q DataType
reifyDataType Name
name
[Name]
classParamNames <- [Name] -> (Name -> Q Name) -> Q [Name]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [Name]
dTyVars (Q Name -> Name -> Q Name
forall a b. a -> b -> a
const (String -> Q Name
newName String
"arg"))
Cxt
ctx <- [Name] -> Q Cxt
wrapWithConstraints [Name]
classParamNames
Type
decTy <- [Name] -> Q Type
forall (t :: * -> *). Foldable t => t Name -> Q Type
makeInstanceType [Name]
classParamNames
Dec
sdr <- [DataCon] -> Q Dec
makeSeeder [DataCon]
dCons
[Dec] -> Q [Dec]
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Maybe Overlap -> Cxt -> Type -> [Dec] -> Dec
InstanceD Maybe Overlap
forall a. Maybe a
Nothing Cxt
ctx Type
decTy [Dec
sdr]]
where
wrapWithConstraints :: [Name] -> Q Cxt
wrapWithConstraints = [Q Type] -> Q Cxt
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence ([Q Type] -> Q Cxt) -> ([Name] -> [Q Type]) -> [Name] -> Q Cxt
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
(Name -> [Q Type]) -> [Name] -> [Q Type]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (\Name
cpn -> [ [t| SeedGoblin $(pure (VarT cpn)) |]
, [t| Typeable $(pure (VarT cpn)) |]
])
makeInstanceType :: t Name -> Q Type
makeInstanceType t Name
classParamNames =
[t| SeedGoblin
( $(pure (foldl wrapTyVars (ConT name) classParamNames)) ) |]
wrapTyVars :: Type -> Name -> Type
wrapTyVars Type
acc Name
cpn = Type -> Type -> Type
AppT Type
acc (Name -> Type
VarT Name
cpn)
makeSeeder :: [DataCon] -> Q Dec
makeSeeder :: [DataCon] -> Q Dec
makeSeeder [DataCon]
dcs = do
[Clause]
clauses <- (DataCon -> Q Clause) -> [DataCon] -> Q [Clause]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM DataCon -> Q Clause
makeSeederClause [DataCon]
dcs
Dec -> Q Dec
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Name -> [Clause] -> Dec
FunD (String -> Name
mkName String
"seeder") [Clause]
clauses)
makeSeederClause :: DataCon -> Q Clause
makeSeederClause :: DataCon -> Q Clause
makeSeederClause DataCon
con = do
Name
asName <- String -> Q Name
newName String
"argAs"
[Name]
fieldNames <- [(Maybe Name, Type)] -> ((Maybe Name, Type) -> Q Name) -> Q [Name]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM (DataCon -> [(Maybe Name, Type)]
dcFields DataCon
con) (Q Name -> (Maybe Name, Type) -> Q Name
forall a b. a -> b -> a
const (String -> Q Name
newName String
"field"))
let pat :: Pat
pat = Name -> Pat -> Pat
AsP Name
asName (Name -> [Pat] -> Pat
ConP (DataCon -> Name
dcName DataCon
con) ((Name -> Pat) -> [Name] -> [Pat]
forall a b. (a -> b) -> [a] -> [b]
map Name -> Pat
VarP [Name]
fieldNames))
Exp
seedAs <- [| () <$ saveInBagOfTricks $(pure (VarE asName)) |]
[Exp]
seedRest <- [Name] -> (Name -> Q Exp) -> Q [Exp]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [Name]
fieldNames ((Name -> Q Exp) -> Q [Exp]) -> (Name -> Q Exp) -> Q [Exp]
forall a b. (a -> b) -> a -> b
$ \Name
vName -> do
[| seeder $(pure (VarE vName)) |]
let stmts :: [Stmt]
stmts = (Exp -> Stmt) -> [Exp] -> [Stmt]
forall a b. (a -> b) -> [a] -> [b]
map Exp -> Stmt
NoBindS (Exp
seedAsExp -> [Exp] -> [Exp]
forall a. a -> [a] -> [a]
:[Exp]
seedRest)
Clause -> Q Clause
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Pat] -> Body -> [Dec] -> Clause
Clause [Pat
pat] (Exp -> Body
NormalB ([Stmt] -> Exp
DoE [Stmt]
stmts)) [])
makeConPacker :: Name -> [Name] -> Exp
makeConPacker :: Name -> [Name] -> Exp
makeConPacker Name
conName [Name]
argNames =
let body :: Exp
body = (Exp -> Name -> Exp) -> Exp -> [Name] -> Exp
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl (\Exp
acc Name
v -> Exp -> Exp -> Exp
AppE Exp
acc (Name -> Exp
VarE Name
v))
(Name -> Exp
ConE Name
conName)
[Name]
argNames
in [Pat] -> Exp -> Exp
LamE ((Name -> Pat) -> [Name] -> [Pat]
forall a b. (a -> b) -> [a] -> [b]
map Name -> Pat
VarP [Name]
argNames) Exp
body
makeAccessors :: Name -> [Name] -> [Exp]
makeAccessors :: Name -> [Name] -> [Exp]
makeAccessors Name
conName [Name]
argNames =
[ let front :: [Pat]
front = Int -> Pat -> [Pat]
forall a. Int -> a -> [a]
replicate Int
i Pat
WildP
back :: [Pat]
back = Int -> Pat -> [Pat]
forall a. Int -> a -> [a]
replicate ([Name] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Name]
argNames Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) Pat
WildP
arg :: Name
arg = [Name]
argNames [Name] -> Int -> Name
forall a. [a] -> Int -> a
!! Int
i
pat :: Pat
pat = Name -> [Pat] -> Pat
ConP Name
conName ([Pat]
front [Pat] -> [Pat] -> [Pat]
forall a. [a] -> [a] -> [a]
++ [Name -> Pat
VarP Name
arg] [Pat] -> [Pat] -> [Pat]
forall a. [a] -> [a] -> [a]
++ [Pat]
back)
in [Pat] -> Exp -> Exp
LamE [Pat
pat] (Name -> Exp
VarE Name
arg)
| Int
i <- [Int
0 .. [Name] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Name]
argNames Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1]
]
mkPureDec :: String -> Q Dec
mkPureDec :: String -> Q Dec
mkPureDec String
name = do
Exp
body <- [| pure |]
Dec -> Q Dec
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Name -> [Clause] -> Dec
FunD (String -> Name
mkName String
name) [[Pat] -> Body -> [Dec] -> Clause
Clause [] (Exp -> Body
NormalB Exp
body) []])