{-# LANGUAGE TemplateHaskell #-}
module Reflex.Vty.Test.Monad.Host.TH where
import Prelude (foldl)
import Relude hiding (getFirst, Type)
import Data.Char (toLower)
import Language.Haskell.TH
import Reflex
import Reflex.Vty.Test.Monad.Host
import Reflex.Host.Class (EventTrigger, newEventWithTriggerRef)
import Control.Monad.Ref
tv :: Q Type
tv :: Q Type
tv = forall (m :: * -> *). Quote m => Name -> m Type
varT forall a b. (a -> b) -> a -> b
$ String -> Name
mkName String
"t"
tinput :: String -> String -> Q Exp
tinput :: String -> String -> Q Exp
tinput String
name String
suffix = forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Exp -> Exp -> Exp
AppE (Name -> Exp
VarE forall a b. (a -> b) -> a -> b
$ Name -> String -> Name
convertNameToPrefixedNameField (String -> Name
mkName String
name) (String
"InputEvents_"forall a. Semigroup a => a -> a -> a
<>String
suffix)) (Name -> Exp
VarE forall a b. (a -> b) -> a -> b
$ Name
getAppInputEventsArgName)
toutputcon :: String -> Q Exp
toutputcon :: String -> Q Exp
toutputcon String
name = forall (m :: * -> *). Quote m => Name -> m Exp
conE forall a b. (a -> b) -> a -> b
$ String -> Name
mkName (String
name forall a. Semigroup a => a -> a -> a
<> String
"_Output")
declareStuff :: String -> [(String, Q Type)] -> [(String, Q Type)] -> Q Exp -> Q [Dec]
declareStuff :: String
-> [(String, Q Type)] -> [(String, Q Type)] -> Q Exp -> Q [Dec]
declareStuff String
name' [(String, Q Type)]
inputEventTypes [(String, Q Type)]
outputTypes Q Exp
body = do
let
name :: Name
name = String -> Name
mkName String
name'
[Dec]
nd <- Name -> Q [Dec]
declareNetworkData Name
name
[Dec]
ni <- Name
-> [(String, Q Type)] -> [(String, Q Type)] -> Q Exp -> Q [Dec]
declareNetworkInstance Name
name [(String, Q Type)]
inputEventTypes [(String, Q Type)]
outputTypes Q Exp
body
return ([Dec]
ndforall a. Semigroup a => a -> a -> a
<>[Dec]
ni)
getAppInputEventsArgName :: Name
getAppInputEventsArgName :: Name
getAppInputEventsArgName = String -> Name
mkName String
"inputEvs_____donotusethisvariablenameforanythingelse"
declareNetworkData :: Name -> Q [Dec]
declareNetworkData :: Name -> Q [Dec]
declareNetworkData Name
name = do
let
k_m :: Type
k_m = Type -> Name -> Type -> Type
InfixT Type
StarT ''(->) Type
StarT
Name
tv_t <- forall (m :: * -> *). Quote m => String -> m Name
newName String
"t"
Name
tv_m <- forall (m :: * -> *). Quote m => String -> m Name
newName String
"m"
return $ [Cxt
-> Name
-> [TyVarBndr ()]
-> Maybe Type
-> [Con]
-> [DerivClause]
-> Dec
DataD [] Name
name [forall flag. Name -> flag -> TyVarBndr flag
PlainTV Name
tv_t (), forall flag. Name -> flag -> Type -> TyVarBndr flag
KindedTV Name
tv_m () Type
k_m] forall a. Maybe a
Nothing [] []]
declareNetworkInstance :: Name -> [(String, Q Type)] -> [(String, Q Type)] -> Q Exp -> Q [Dec]
declareNetworkInstance :: Name
-> [(String, Q Type)] -> [(String, Q Type)] -> Q Exp -> Q [Dec]
declareNetworkInstance Name
name [(String, Q Type)]
inputEventTypes [(String, Q Type)]
outputTypes Q Exp
body = do
let
v_t :: Type
v_t = Name -> Type
VarT forall a b. (a -> b) -> a -> b
$ String -> Name
mkName String
"t"
v_m :: Type
v_m = Name -> Type
VarT forall a b. (a -> b) -> a -> b
$ String -> Name
mkName String
"m"
cxt1 :: Type
cxt1 = Type -> Type -> Type
AppT (Type -> Type -> Type
AppT (Name -> Type
ConT forall a b. (a -> b) -> a -> b
$ String -> Name
mkName String
"MonadVtyApp") Type
v_t) forall a b. (a -> b) -> a -> b
$ Type -> Type -> Type
AppT (Type -> Type -> Type
AppT (Name -> Type
ConT forall a b. (a -> b) -> a -> b
$ String -> Name
mkName String
"TestGuestT") Type
v_t) Type
v_m
cxt2 :: Type
cxt2 = Type -> Type -> Type
AppT (Type -> Type -> Type
AppT (Name -> Type
ConT forall a b. (a -> b) -> a -> b
$ String -> Name
mkName String
"TestGuestConstraints") Type
v_t) forall a b. (a -> b) -> a -> b
$ Type
v_m
v_potatoNetwork :: Type
v_potatoNetwork = Type -> Type -> Type
AppT (Type -> Type -> Type
AppT (Name -> Type
ConT forall a b. (a -> b) -> a -> b
$ Name
name) Type
v_t) Type
v_m
classinstance :: Type
classinstance = Type -> Type -> Type
AppT (Type -> Type -> Type
AppT (Type -> Type -> Type
AppT (Name -> Type
ConT forall a b. (a -> b) -> a -> b
$ String -> Name
mkName String
"ReflexVtyTestApp") Type
v_potatoNetwork) Type
v_t) Type
v_m
Dec
outputs <- Name -> [(String, Q Type)] -> Q Dec
declareOutputs Name
name [(String, Q Type)]
outputTypes
[Dec]
inputs <- Name -> [(String, Q Type)] -> Q [Dec]
declareInputs Name
name [(String, Q Type)]
inputEventTypes
Dec
makeInputsFn <- Name -> [(String, Q Type)] -> Q Dec
declareMakeInputs Name
name [(String, Q Type)]
inputEventTypes
Dec
bodyFn <- Name -> Q Exp -> Q Dec
declareGetApp Name
name Q Exp
body
return $ [Maybe Overlap -> Cxt -> Type -> [Dec] -> Dec
InstanceD forall a. Maybe a
Nothing [Type
cxt1,Type
cxt2] Type
classinstance ((Dec
outputsforall a. a -> [a] -> [a]
:[Dec]
inputs) forall a. Semigroup a => a -> a -> a
<> [Dec
makeInputsFn, Dec
bodyFn])]
normalBang :: Bang
normalBang :: Bang
normalBang = SourceUnpackedness -> SourceStrictness -> Bang
Bang SourceUnpackedness
NoSourceUnpackedness SourceStrictness
NoSourceStrictness
convertNameToPrefixedNameField :: Name -> String -> Name
convertNameToPrefixedNameField :: Name -> String -> Name
convertNameToPrefixedNameField Name
name String
suffix = Name
r where
prefix :: String
prefix = case Name -> String
nameBase Name
name of
[] -> String
""
Char
x:String
xs -> (Char -> Char
toLower Char
x)forall a. a -> [a] -> [a]
:String
xs
r :: Name
r = String -> Name
mkName forall a b. (a -> b) -> a -> b
$ String
"_" forall a. Semigroup a => a -> a -> a
<> String
prefix forall a. Semigroup a => a -> a -> a
<> String
"_" forall a. Semigroup a => a -> a -> a
<> String
suffix
convertNameToPrefixedNameType :: Name -> String -> Name
convertNameToPrefixedNameType :: Name -> String -> Name
convertNameToPrefixedNameType Name
name String
suffix = Name
r where
r :: Name
r = String -> Name
mkName forall a b. (a -> b) -> a -> b
$ Name -> String
nameBase Name
name forall a. Semigroup a => a -> a -> a
<> String
"_" forall a. Semigroup a => a -> a -> a
<> String
suffix
varNetwork :: Name -> Type
varNetwork :: Name -> Type
varNetwork Name
name = Type
r where
v_t :: Type
v_t = Name -> Type
VarT forall a b. (a -> b) -> a -> b
$ String -> Name
mkName String
"t"
v_m :: Type
v_m = Name -> Type
VarT forall a b. (a -> b) -> a -> b
$ String -> Name
mkName String
"m"
r :: Type
r = Type -> Type -> Type
AppT (Type -> Type -> Type
AppT (Name -> Type
ConT forall a b. (a -> b) -> a -> b
$ Name
name) Type
v_t) Type
v_m
declareOutputs :: Name -> [(String, Q Type)] -> Q Dec
declareOutputs :: Name -> [(String, Q Type)] -> Q Dec
declareOutputs Name
name [(String, Q Type)]
outputTypes = do
[(Name, Bang, Type)]
recs <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\(String
x,Q Type
q) -> forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (String
x,) Q Type
q) [(String, Q Type)]
outputTypes) forall a b. (a -> b) -> a -> b
$ \Q (String, Type)
nt -> do
(String
n,Type
t) <- Q (String, Type)
nt
let
fname :: Name
fname = Name -> String -> Name
convertNameToPrefixedNameField Name
name (String
"Output_" forall a. Semigroup a => a -> a -> a
<> String
n)
forall (m :: * -> *) a. Monad m => a -> m a
return (Name
fname, Bang
normalBang, Type
t)
let
recname :: Name
recname = Name -> String -> Name
convertNameToPrefixedNameType Name
name String
"Output"
cs :: [Con]
cs = [Name -> [(Name, Bang, Type)] -> Con
RecC Name
recname [(Name, Bang, Type)]
recs]
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Cxt
-> Maybe [TyVarBndr ()]
-> Type
-> Maybe Type
-> [Con]
-> [DerivClause]
-> Dec
DataInstD [] forall a. Maybe a
Nothing (Type -> Type -> Type
AppT (Name -> Type
ConT forall a b. (a -> b) -> a -> b
$ String -> Name
mkName String
"VtyAppOutput") (Name -> Type
varNetwork Name
name)) forall a. Maybe a
Nothing [Con]
cs []
mkvar :: String -> Q Type
mkvar :: String -> Q Type
mkvar = forall (m :: * -> *). Quote m => Name -> m Type
varT forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Name
mkName
declareInputs :: Name -> [(String, Q Type)] -> Q [Dec]
declareInputs :: Name -> [(String, Q Type)] -> Q [Dec]
declareInputs Name
name [(String, Q Type)]
inputEventTypes = do
[((Name, Bang, Type), (Name, Bang, Type))]
recs <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\(String
x,Q Type
q) -> forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (String
x,) Q Type
q) [(String, Q Type)]
inputEventTypes) forall a b. (a -> b) -> a -> b
$ \Q (String, Type)
nt -> do
(String
n, Type
t) <- Q (String, Type)
nt
let
infname :: Name
infname = Name -> String -> Name
convertNameToPrefixedNameField Name
name (String
"InputEvents_" forall a. Semigroup a => a -> a -> a
<> String
n)
trigfname :: Name
trigfname = Name -> String -> Name
convertNameToPrefixedNameField Name
name (String
"InputTriggerRefs_" forall a. Semigroup a => a -> a -> a
<> String
n)
Type
int <- [t|Event $(tv) $(return t)|]
Type
trigt <- [t| Ref $(mkvar "m") (Maybe (EventTrigger $(tv) $(return t))) |]
return ((Name
infname, Bang
normalBang, Type
int), (Name
trigfname, Bang
normalBang, Type
trigt))
let
([(Name, Bang, Type)]
inrecs, [(Name, Bang, Type)]
trigrecs) = forall a b. [(a, b)] -> ([a], [b])
unzip [((Name, Bang, Type), (Name, Bang, Type))]
recs
incs :: [Con]
incs = [Name -> [(Name, Bang, Type)] -> Con
RecC (Name -> String -> Name
convertNameToPrefixedNameType Name
name String
"InputEvents") [(Name, Bang, Type)]
inrecs]
trigcs :: [Con]
trigcs = [Name -> [(Name, Bang, Type)] -> Con
RecC (Name -> String -> Name
convertNameToPrefixedNameType Name
name String
"InputTriggerRefs") [(Name, Bang, Type)]
trigrecs]
indi :: Dec
indi = Cxt
-> Maybe [TyVarBndr ()]
-> Type
-> Maybe Type
-> [Con]
-> [DerivClause]
-> Dec
DataInstD [] forall a. Maybe a
Nothing (Type -> Type -> Type
AppT (Name -> Type
ConT forall a b. (a -> b) -> a -> b
$ String -> Name
mkName String
"VtyAppInputEvents") (Name -> Type
varNetwork Name
name)) forall a. Maybe a
Nothing [Con]
incs []
trigdi :: Dec
trigdi = Cxt
-> Maybe [TyVarBndr ()]
-> Type
-> Maybe Type
-> [Con]
-> [DerivClause]
-> Dec
DataInstD [] forall a. Maybe a
Nothing (Type -> Type -> Type
AppT (Name -> Type
ConT forall a b. (a -> b) -> a -> b
$ String -> Name
mkName String
"VtyAppInputTriggerRefs") (Name -> Type
varNetwork Name
name)) forall a. Maybe a
Nothing [Con]
trigcs []
forall (m :: * -> *) a. Monad m => a -> m a
return [Dec
indi, Dec
trigdi]
declareMakeInputs :: Name -> [(String, Q Type)] -> Q Dec
declareMakeInputs :: Name -> [(String, Q Type)] -> Q Dec
declareMakeInputs Name
name [(String, Q Type)]
inputEventTypes = do
[(Name, Name)]
varnames <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\(String
x,Q Type
q) -> forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (String
x,) Q Type
q) [(String, Q Type)]
inputEventTypes) forall a b. (a -> b) -> a -> b
$ \Q (String, Type)
nt -> do
(String
n, Type
t) <- Q (String, Type)
nt
Name
evname <- forall (m :: * -> *). Quote m => String -> m Name
newName String
"ev"
Name
trefname <- forall (m :: * -> *). Quote m => String -> m Name
newName String
"ref"
return (Name
evname, Name
trefname)
[Stmt]
refstmts <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [(Name, Name)]
varnames forall a b. (a -> b) -> a -> b
$ \(Name
evname,Name
trefname) -> do
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Pat -> Exp -> Stmt
BindS ([Pat] -> Pat
TupP [Name -> Pat
VarP Name
evname, Name -> Pat
VarP Name
trefname]) forall a b. (a -> b) -> a -> b
$ Name -> Exp
VarE (String -> Name
mkName String
"newEventWithTriggerRef")
let
returnstmtsfst :: Exp
returnstmtsfst = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Exp -> Exp -> Exp
AppE (Name -> Exp
ConE forall a b. (a -> b) -> a -> b
$ Name -> String -> Name
convertNameToPrefixedNameType Name
name String
"InputEvents") (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Name -> Exp
VarE forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) [(Name, Name)]
varnames)
returnstmtssnd :: Exp
returnstmtssnd = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Exp -> Exp -> Exp
AppE (Name -> Exp
ConE forall a b. (a -> b) -> a -> b
$ Name -> String -> Name
convertNameToPrefixedNameType Name
name String
"InputTriggerRefs") (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Name -> Exp
VarE forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd) [(Name, Name)]
varnames)
Exp
returnstmts <- [|return ($(return returnstmtsfst),$(return returnstmtssnd))|]
let
b :: Body
b = Exp -> Body
NormalB forall a b. (a -> b) -> a -> b
$ Maybe ModName -> [Stmt] -> Exp
DoE forall a. Maybe a
Nothing ([Stmt]
refstmts forall a. Semigroup a => a -> a -> a
<> [Exp -> Stmt
NoBindS Exp
returnstmts])
c :: Clause
c = [Pat] -> Body -> [Dec] -> Clause
Clause [] Body
b []
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Name -> [Clause] -> Dec
FunD (String -> Name
mkName String
"makeInputs") [Clause
c]
declareGetApp :: Name -> Q Exp -> Q Dec
declareGetApp :: Name -> Q Exp -> Q Dec
declareGetApp Name
name Q Exp
body' = do
Exp
body <- Q Exp
body'
let
b :: Body
b = Exp -> Body
NormalB forall a b. (a -> b) -> a -> b
$ Exp
body
c :: Clause
c = [Pat] -> Body -> [Dec] -> Clause
Clause [Name -> Pat
VarP forall a b. (a -> b) -> a -> b
$ Name
getAppInputEventsArgName] Body
b []
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Name -> [Clause] -> Dec
FunD (String -> Name
mkName String
"getApp") [Clause
c]