{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE ExistentialQuantification #-}


module AsyncRattus.Derive (continuous) where

import AsyncRattus.InternalPrimitives
import Language.Haskell.TH
import Language.Haskell.TH.Syntax
import Control.Monad


data DataInfo = forall flag . DataInfo Cxt Name [TyVarBndr flag] [Con] [DerivClause] 

{-|
  This function provides a list (of the given length) of new names based
  on the given string.
-}
newNames :: Int -> String -> Q [Name]
newNames :: Int -> String -> Q [Name]
newNames Int
n String
name = Int -> Q Name -> Q [Name]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM Int
n (String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName String
name)


{-|
  This is the @Q@-lifted version of 'abstractNewtype.
-}
abstractNewtypeQ :: Q Info -> Q (Maybe DataInfo)
abstractNewtypeQ :: Q Info -> Q (Maybe DataInfo)
abstractNewtypeQ = (Info -> Maybe DataInfo) -> Q Info -> Q (Maybe DataInfo)
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM Info -> Maybe DataInfo
abstractNewtype


{-| Apply a class name to type arguments to construct a type class
    constraint.
-}

mkClassP :: Name -> [Type] -> Type
mkClassP :: Name -> [Type] -> Type
mkClassP Name
name = (Type -> Type -> Type) -> Type -> [Type] -> Type
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Type -> Type -> Type
AppT (Name -> Type
ConT Name
name)


{-| This function provides the name and the arity of the given data
constructor, and if it is a GADT also its type.
-}
normalCon :: Con -> [(Name,[StrictType], Maybe Type)]
normalCon :: Con -> [(Name, [StrictType], Maybe Type)]
normalCon (NormalC Name
constr [StrictType]
args) = [(Name
constr, [StrictType]
args, Maybe Type
forall a. Maybe a
Nothing)]
normalCon (RecC Name
constr [VarBangType]
args) = [(Name
constr, (VarBangType -> StrictType) -> [VarBangType] -> [StrictType]
forall a b. (a -> b) -> [a] -> [b]
map (\(Name
_,Bang
s,Type
t) -> (Bang
s,Type
t)) [VarBangType]
args, Maybe Type
forall a. Maybe a
Nothing)]
normalCon (InfixC StrictType
a Name
constr StrictType
b) = [(Name
constr, [StrictType
a,StrictType
b], Maybe Type
forall a. Maybe a
Nothing)]
normalCon (ForallC [TyVarBndr Specificity]
_ [Type]
_ Con
constr) = Con -> [(Name, [StrictType], Maybe Type)]
normalCon Con
constr
normalCon (GadtC (Name
constr:[Name]
_) [StrictType]
args Type
typ) = [(Name
constr,[StrictType]
args,Type -> Maybe Type
forall a. a -> Maybe a
Just Type
typ)]
normalCon (RecGadtC (Name
constr : [Name]
_) [VarBangType]
args Type
typ) = [(Name
constr,(VarBangType -> StrictType) -> [VarBangType] -> [StrictType]
forall a b. (a -> b) -> [a] -> [b]
map VarBangType -> StrictType
forall {a} {a} {b}. (a, a, b) -> (a, b)
dropFst [VarBangType]
args,Type -> Maybe Type
forall a. a -> Maybe a
Just Type
typ)]
  where dropFst :: (a, a, b) -> (a, b)
dropFst (a
_,a
x,b
y) = (a
x,b
y)
normalCon Con
_ = String -> [(Name, [StrictType], Maybe Type)]
forall a. HasCallStack => String -> a
error String
"missing case for 'normalCon'"

normalCon' :: Con -> [(Name,[Type], Maybe Type)]
normalCon' :: Con -> [(Name, [Type], Maybe Type)]
normalCon' Con
con = ((Name, [StrictType], Maybe Type) -> (Name, [Type], Maybe Type))
-> [(Name, [StrictType], Maybe Type)]
-> [(Name, [Type], Maybe Type)]
forall a b. (a -> b) -> [a] -> [b]
map (Name, [StrictType], Maybe Type) -> (Name, [Type], Maybe Type)
forall {a} {a} {b} {c}. (a, [(a, b)], c) -> (a, [b], c)
conv (Con -> [(Name, [StrictType], Maybe Type)]
normalCon Con
con)
  where conv :: (a, [(a, b)], c) -> (a, [b], c)
conv (a
n, [(a, b)]
ts, c
t) = (a
n, ((a, b) -> b) -> [(a, b)] -> [b]
forall a b. (a -> b) -> [a] -> [b]
map (a, b) -> b
forall a b. (a, b) -> b
snd [(a, b)]
ts, c
t)
  
mkInstanceD :: Cxt -> Type -> [Dec] -> Dec
mkInstanceD :: [Type] -> Type -> [Dec] -> Dec
mkInstanceD [Type]
cxt Type
ty [Dec]
decs = Maybe Overlap -> [Type] -> Type -> [Dec] -> Dec
InstanceD Maybe Overlap
forall a. Maybe a
Nothing [Type]
cxt Type
ty [Dec]
decs

{-|
  This function returns the name of a bound type variable
-}
tyVarBndrName :: TyVarBndr flag -> Name
tyVarBndrName (PlainTV Name
n flag
_) = Name
n
tyVarBndrName (KindedTV Name
n flag
_ Type
_) = Name
n

{-|
  This function abstracts away @newtype@ declaration, it turns them into
  @data@ declarations.
-}
abstractNewtype :: Info -> Maybe DataInfo
abstractNewtype :: Info -> Maybe DataInfo
abstractNewtype (TyConI (NewtypeD [Type]
cxt Name
name [TyVarBndr ()]
args Maybe Type
_ Con
constr [DerivClause]
derive))
    = DataInfo -> Maybe DataInfo
forall a. a -> Maybe a
Just ([Type]
-> Name -> [TyVarBndr ()] -> [Con] -> [DerivClause] -> DataInfo
forall flag.
[Type]
-> Name -> [TyVarBndr flag] -> [Con] -> [DerivClause] -> DataInfo
DataInfo [Type]
cxt Name
name [TyVarBndr ()]
args [Con
constr] [DerivClause]
derive)
abstractNewtype (TyConI (DataD [Type]
cxt Name
name [TyVarBndr ()]
args Maybe Type
_ [Con]
constrs [DerivClause]
derive))
    = DataInfo -> Maybe DataInfo
forall a. a -> Maybe a
Just ([Type]
-> Name -> [TyVarBndr ()] -> [Con] -> [DerivClause] -> DataInfo
forall flag.
[Type]
-> Name -> [TyVarBndr flag] -> [Con] -> [DerivClause] -> DataInfo
DataInfo [Type]
cxt Name
name [TyVarBndr ()]
args [Con]
constrs [DerivClause]
derive)
abstractNewtype Info
_ = Maybe DataInfo
forall a. Maybe a
Nothing

continuous :: Name -> Q [Dec]
continuous :: Name -> Q [Dec]
continuous Name
fname = do
  Just (DataInfo [Type]
_cxt Name
name [TyVarBndr flag]
args [Con]
constrs [DerivClause]
_deriving) <- Q Info -> Q (Maybe DataInfo)
abstractNewtypeQ (Q Info -> Q (Maybe DataInfo)) -> Q Info -> Q (Maybe DataInfo)
forall a b. (a -> b) -> a -> b
$ Name -> Q Info
reify Name
fname
  let argNames :: [Type]
argNames = (TyVarBndr flag -> Type) -> [TyVarBndr flag] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map (Name -> Type
VarT (Name -> Type)
-> (TyVarBndr flag -> Name) -> TyVarBndr flag -> Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TyVarBndr flag -> Name
forall {flag}. TyVarBndr flag -> Name
tyVarBndrName) [TyVarBndr flag]
args
      complType :: Type
complType = (Type -> Type -> Type) -> Type -> [Type] -> Type
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Type -> Type -> Type
AppT (Name -> Type
ConT Name
name) [Type]
argNames
      preCond :: [Type]
preCond = (Type -> Type) -> [Type] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map (Name -> [Type] -> Type
mkClassP ''Continuous ([Type] -> Type) -> (Type -> [Type]) -> Type -> Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Type -> [Type] -> [Type]
forall a. a -> [a] -> [a]
: [])) [Type]
argNames
      classType :: Type
classType = Type -> Type -> Type
AppT (Name -> Type
ConT ''Continuous) Type
complType
  let constrs' :: [(Name, [Type], Maybe Type)]
constrs' = (Con -> [(Name, [Type], Maybe Type)])
-> [Con] -> [(Name, [Type], Maybe Type)]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Con -> [(Name, [Type], Maybe Type)]
normalCon' [Con]
constrs
  Dec
progressAndNextDecl <- Name -> [Q Clause] -> Q Dec
forall (m :: * -> *). Quote m => Name -> [m Clause] -> m Dec
funD 'progressAndNext (((Name, [Type], Maybe Type) -> Q Clause)
-> [(Name, [Type], Maybe Type)] -> [Q Clause]
forall a b. (a -> b) -> [a] -> [b]
map (Name, [Type], Maybe Type) -> Q Clause
forall {t :: * -> *} {a} {c}.
Foldable t =>
(Name, t a, c) -> Q Clause
genProgressAndNext [(Name, [Type], Maybe Type)]
constrs')
  Dec
progressInternalDecl <- Name -> [Q Clause] -> Q Dec
forall (m :: * -> *). Quote m => Name -> [m Clause] -> m Dec
funD 'progressInternal (((Name, [Type], Maybe Type) -> Q Clause)
-> [(Name, [Type], Maybe Type)] -> [Q Clause]
forall a b. (a -> b) -> [a] -> [b]
map (Name, [Type], Maybe Type) -> Q Clause
forall {t :: * -> *} {a} {c}.
Foldable t =>
(Name, t a, c) -> Q Clause
genProgressInternal [(Name, [Type], Maybe Type)]
constrs')
  Dec
nextProgressDecl <- Name -> [Q Clause] -> Q Dec
forall (m :: * -> *). Quote m => Name -> [m Clause] -> m Dec
funD 'nextProgress (((Name, [Type], Maybe Type) -> Q Clause)
-> [(Name, [Type], Maybe Type)] -> [Q Clause]
forall a b. (a -> b) -> [a] -> [b]
map (Name, [Type], Maybe Type) -> Q Clause
forall {t :: * -> *} {a} {c}.
Foldable t =>
(Name, t a, c) -> Q Clause
genNextProgress [(Name, [Type], Maybe Type)]
constrs')
  [Dec] -> Q [Dec]
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return [[Type] -> Type -> [Dec] -> Dec
mkInstanceD [Type]
preCond Type
classType [Dec
progressAndNextDecl,Dec
progressInternalDecl,Dec
nextProgressDecl]]
      where genProgressAndNext :: (Name, t a, c) -> Q Clause
genProgressAndNext (Name
constr, t a
args,c
_) = do
              let n :: Int
n = t a -> Int
forall a. t a -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length t a
args
              [Name]
varNs <- Int -> String -> Q [Name]
newNames Int
n String
"x"
              [Name]
varNsR <- Int -> String -> Q [Name]
newNames Int
n String
"y"
              [Name]
varNsS <- Int -> String -> Q [Name]
newNames Int
n String
"z"
              Name
varIn <- String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName String
"_inp"
              let pat :: Pat
pat = Name -> [Type] -> [Pat] -> Pat
ConP Name
constr [] ([Pat] -> Pat) -> [Pat] -> Pat
forall a b. (a -> b) -> a -> b
$ (Name -> Pat) -> [Name] -> [Pat]
forall a b. (a -> b) -> [a] -> [b]
map Name -> Pat
VarP [Name]
varNs

              Exp
progressInternalExp <- [|progressAndNext|]
              let lets :: [Dec]
lets = (Name -> Name -> Name -> Dec)
-> [Name] -> [Name] -> [Name] -> [Dec]
forall a b c d. (a -> b -> c -> d) -> [a] -> [b] -> [c] -> [d]
zipWith3 (\ Name
x Name
y Name
z -> Pat -> Body -> [Dec] -> Dec
ValD ([Pat] -> Pat
TupP [Name -> Pat
VarP Name
y, Name -> Pat
VarP Name
z]) (Exp -> Body
NormalB (Exp
progressInternalExp Exp -> Exp -> Exp
`AppE` Name -> Exp
VarE Name
varIn Exp -> Exp -> Exp
`AppE` Name -> Exp
VarE Name
x)) []) [Name]
varNs [Name]
varNsR [Name]
varNsS
              Exp
clockUnionExp <- [|clockUnion|]
              Exp
result <- [Q Exp] -> Q Exp
forall (m :: * -> *). Quote m => [m Exp] -> m Exp
appsE ( Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
conE Name
constr Q Exp -> [Q Exp] -> [Q Exp]
forall a. a -> [a] -> [a]
: ((Name -> Q Exp) -> [Name] -> [Q Exp]
forall a b. (a -> b) -> [a] -> [b]
map Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE [Name]
varNsR))
              Exp
clock <- if Int
n Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 then [|emptyClock|] else Exp -> Q Exp
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return ((Exp -> Exp -> Exp) -> [Exp] -> Exp
forall a. (a -> a -> a) -> [a] -> a
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldl1 (\ Exp
x Exp
y -> (Exp
clockUnionExp Exp -> Exp -> Exp
`AppE` Exp
x) Exp -> Exp -> Exp
`AppE` Exp
y)  ((Name -> Exp) -> [Name] -> [Exp]
forall a b. (a -> b) -> [a] -> [b]
map Name -> Exp
VarE [Name]
varNsS))
              let body :: Exp
body = [Dec] -> Exp -> Exp
LetE [Dec]
lets ([Maybe Exp] -> Exp
TupE [Exp -> Maybe Exp
forall a. a -> Maybe a
Just Exp
result, Exp -> Maybe Exp
forall a. a -> Maybe a
Just Exp
clock])
              Clause -> Q Clause
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return (Clause -> Q Clause) -> Clause -> Q Clause
forall a b. (a -> b) -> a -> b
$ [Pat] -> Body -> [Dec] -> Clause
Clause [Name -> Pat
VarP Name
varIn, Pat
pat] (Exp -> Body
NormalB Exp
body) []
            genProgressInternal :: (Name, t a, c) -> Q Clause
genProgressInternal (Name
constr, t a
args,c
_) = do
              let n :: Int
n = t a -> Int
forall a. t a -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length t a
args
              [Name]
varNs <- Int -> String -> Q [Name]
newNames Int
n String
"x"
              Name
varIn <- String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName String
"_inp"
              let pat :: Pat
pat = Name -> [Type] -> [Pat] -> Pat
ConP Name
constr [] ([Pat] -> Pat) -> [Pat] -> Pat
forall a b. (a -> b) -> a -> b
$ (Name -> Pat) -> [Name] -> [Pat]
forall a b. (a -> b) -> [a] -> [b]
map Name -> Pat
VarP [Name]
varNs
                  allVars :: [Q Exp]
allVars = (Name -> Q Exp) -> [Name] -> [Q Exp]
forall a b. (a -> b) -> [a] -> [b]
map Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE [Name]
varNs
                  inpVar :: Q Exp
inpVar = Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
varIn
              Exp
body <- [Q Exp] -> Q Exp
forall (m :: * -> *). Quote m => [m Exp] -> m Exp
appsE ( Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
conE Name
constr Q Exp -> [Q Exp] -> [Q Exp]
forall a. a -> [a] -> [a]
: ((Q Exp -> Q Exp) -> [Q Exp] -> [Q Exp]
forall a b. (a -> b) -> [a] -> [b]
map (\ Q Exp
x -> [|progressInternal $Q Exp
inpVar $Q Exp
x|]) [Q Exp]
allVars))
              Clause -> Q Clause
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return (Clause -> Q Clause) -> Clause -> Q Clause
forall a b. (a -> b) -> a -> b
$ [Pat] -> Body -> [Dec] -> Clause
Clause [Name -> Pat
VarP Name
varIn, Pat
pat] (Exp -> Body
NormalB Exp
body) []
            genNextProgress :: (Name, t a, c) -> Q Clause
genNextProgress (Name
constr, t a
args,c
_) = do
              let n :: Int
n = t a -> Int
forall a. t a -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length t a
args
              [Name]
varNs <- Int -> String -> Q [Name]
newNames Int
n String
"x"
              let pat :: Pat
pat = Name -> [Type] -> [Pat] -> Pat
ConP Name
constr [] ([Pat] -> Pat) -> [Pat] -> Pat
forall a b. (a -> b) -> a -> b
$ (Name -> Pat) -> [Name] -> [Pat]
forall a b. (a -> b) -> [a] -> [b]
map Name -> Pat
VarP [Name]
varNs
                  allVars :: [Q Exp]
allVars = (Name -> Q Exp) -> [Name] -> [Q Exp]
forall a b. (a -> b) -> [a] -> [b]
map Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE [Name]
varNs
              Exp
body <- if Int
n Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 then [|emptyClock|] else (Q Exp -> Q Exp -> Q Exp) -> [Q Exp] -> Q Exp
forall a. (a -> a -> a) -> [a] -> a
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldl1 (\ Q Exp
x Q Exp
y -> [|clockUnion $Q Exp
x $Q Exp
y|]) (((Q Exp -> Q Exp) -> [Q Exp] -> [Q Exp]
forall a b. (a -> b) -> [a] -> [b]
map (\ Q Exp
x -> [|nextProgress $Q Exp
x|]) [Q Exp]
allVars))
              Clause -> Q Clause
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return (Clause -> Q Clause) -> Clause -> Q Clause
forall a b. (a -> b) -> a -> b
$ [Pat] -> Body -> [Dec] -> Clause
Clause [Pat
pat] (Exp -> Body
NormalB Exp
body) []