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

-- | reference the 't' variable your quasi-quotes. e.g. 'Event $(tv) ()'
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"
-- does this capture types in generated scope? Probably not???
--tv = do
--  Just r <- lookupTypeName "t"
--  varT r

-- | reference a specific input event
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)

-- | reference the output constructor
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")

-- | call me to generate code
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"
  -- not sure if KindedTV is necessary
  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
    --instance (MonadVtyApp t (TestGuestT t m), TestGuestConstraints t m) => ReflexVtyTestApp ([|$(VarT name)|] t m) t m where
    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
  -- same but using quasiquoters
  --cxt1 <- [t| $(conT $ mkName "MonadVtyApp") $(varT $ mkName "t") ($(conT $ mkName "TestGuestT") $(varT $ mkName "t") $(varT $ mkName "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]