{-# 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 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
n, (StrictType -> Type) -> [StrictType] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map StrictType -> Type
forall a b. (a, b) -> b
snd [StrictType]
ts, Maybe Type
t)
  where (Name
n, [StrictType]
ts, Maybe Type
t) = Con -> (Name, [StrictType], Maybe Type)
normalCon Con
con
      

-- | Same as normalCon' but expands type synonyms.
normalConExp :: Con -> Q (Name,[Type], Maybe Type)
normalConExp :: Con -> Q (Name, [Type], Maybe Type)
normalConExp Con
c = do
  let (Name
n,[Type]
ts,Maybe Type
t) = Con -> (Name, [Type], Maybe Type)
normalCon' Con
c
  (Name, [Type], Maybe Type) -> Q (Name, [Type], Maybe Type)
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return (Name
n, [Type]
ts,Maybe Type
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
  [(Name, [Type], Maybe Type)]
constrs' <- (Con -> Q (Name, [Type], Maybe Type))
-> [Con] -> Q [(Name, [Type], Maybe Type)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM Con -> Q (Name, [Type], Maybe Type)
normalConExp [Con]
constrs
  Dec
promDecl <- Name -> [Q Clause] -> Q Dec
forall (m :: * -> *). Quote m => Name -> [m Clause] -> m Dec
funD 'progressInternal ([(Name, [Type], Maybe Type)] -> [Q Clause]
forall {a} {c}. [(Name, [a], c)] -> [Q Clause]
promClauses [(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
promDecl]]
      where promClauses :: [(Name, [a], c)] -> [Q Clause]
promClauses = ((Name, [a], c) -> Q Clause) -> [(Name, [a], c)] -> [Q Clause]
forall a b. (a -> b) -> [a] -> [b]
map (Name, [a], c) -> Q Clause
forall {t :: * -> *} {a} {c}.
Foldable t =>
(Name, t a, c) -> Q Clause
genPromClause
            genPromClause :: (Name, t a, c) -> Q Clause
genPromClause (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) []