{-# LANGUAGE TemplateHaskell #-}

module Hyper.TH.Context
    ( makeHContext
    ) where

import qualified Control.Lens as Lens
import Hyper.Class.Context (HContext (..))
import Hyper.Class.Functor (HFunctor (..))
import Hyper.Combinator.Func (HFunc (..), _HFunc)
import Hyper.TH.Internal.Utils
import Language.Haskell.TH
import Language.Haskell.TH.Datatype (ConstructorVariant (..))

import Hyper.Internal.Prelude

makeHContext :: Name -> DecsQ
makeHContext :: Name -> DecsQ
makeHContext Name
typeName = Name -> Q TypeInfo
makeTypeInfo Name
typeName forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= TypeInfo -> DecsQ
makeHContextForType

makeHContextForType :: TypeInfo -> DecsQ
makeHContextForType :: TypeInfo -> DecsQ
makeHContextForType TypeInfo
info =
    forall (m :: * -> *).
Quote m =>
m Cxt -> m Type -> [m Dec] -> m Dec
instanceD
        (Cxt -> CxtQ
simplifyContext (TypeInfo -> Cxt
makeContext TypeInfo
info))
        [t|HContext $(pure (tiInstance info))|]
        [ Name -> Inline -> RuleMatch -> Phases -> Pragma
InlineP 'hcontext Inline
Inline RuleMatch
FunLike Phases
AllPhases forall a b. a -> (a -> b) -> b
& Pragma -> Dec
PragmaD forall a b. a -> (a -> b) -> b
& forall (f :: * -> *) a. Applicative f => a -> f a
pure
        , forall (m :: * -> *). Quote m => Name -> [m Clause] -> m Dec
funD 'hcontext (TypeInfo
-> [(Name, ConstructorVariant, [Either Type CtrTypePattern])]
tiConstructors TypeInfo
info forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> (Name, ConstructorVariant, [Either Type CtrTypePattern])
-> Q Clause
makeHContextCtr)
        ]
        forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> (forall a. a -> [a] -> [a]
: [])

makeContext :: TypeInfo -> [Pred]
makeContext :: TypeInfo -> Cxt
makeContext TypeInfo
info =
    TypeInfo
-> [(Name, ConstructorVariant, [Either Type CtrTypePattern])]
tiConstructors TypeInfo
info forall s a. s -> Getting (Endo [a]) s a -> [a]
^.. forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s t a b. Field3 s t a b => Lens s t a b
Lens._3 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall c a b. Prism (Either c a) (Either c b) a b
Lens._Right forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= CtrTypePattern -> Cxt
ctxForPat
    where
        ctxForPat :: CtrTypePattern -> Cxt
ctxForPat (GenEmbed Type
t) = Type -> Cxt
embed Type
t
        ctxForPat (FlatEmbed TypeInfo
x) = Type -> Cxt
embed (TypeInfo -> Type
tiInstance TypeInfo
x)
        ctxForPat CtrTypePattern
_ = []
        embed :: Type -> Cxt
embed Type
t = [Name -> Type
ConT ''HContext Type -> Type -> Type
`AppT` Type
t, Name -> Type
ConT ''HFunctor Type -> Type -> Type
`AppT` Type
t]

makeHContextCtr ::
    (Name, ConstructorVariant, [Either Type CtrTypePattern]) -> Q Clause
makeHContextCtr :: (Name, ConstructorVariant, [Either Type CtrTypePattern])
-> Q Clause
makeHContextCtr (Name
cName, ConstructorVariant
_, []) =
    forall (m :: * -> *).
Quote m =>
[m Pat] -> m Body -> [m Dec] -> m Clause
clause [forall (m :: * -> *). Quote m => Name -> [m Pat] -> m Pat
conP Name
cName []] (forall (m :: * -> *). Quote m => m Exp -> m Body
normalB (forall (m :: * -> *). Quote m => Name -> m Exp
conE Name
cName)) []
makeHContextCtr (Name
cName, RecordConstructor [Name]
fieldNames, [Either Type CtrTypePattern]
cFields) =
    forall (m :: * -> *).
Quote m =>
[m Pat] -> m Body -> [m Dec] -> m Clause
clause
        [Name
varWhole forall (m :: * -> *). Quote m => Name -> m Pat -> m Pat
`asP` forall (m :: * -> *). Quote m => Name -> [m Pat] -> m Pat
conP Name
cName ([Name]
cVars forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> forall (m :: * -> *). Quote m => Name -> m Pat
varP)]
        (forall (m :: * -> *). Quote m => m Exp -> m Body
normalB (forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE (forall (m :: * -> *). Quote m => Name -> m Exp
conE Name
cName) (forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith forall {m :: * -> *} {a}.
(Quote m, MonadFail m) =>
Either a CtrTypePattern -> (Name, Name) -> m Exp
bodyFor [Either Type CtrTypePattern]
cFields (forall a b. [a] -> [b] -> [(a, b)]
zip [Name]
fieldNames [Name]
cVars))))
        []
    where
        cVars :: [Name]
cVars =
            [(Int
0 :: Int) ..]
                forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> String -> Name
mkName forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String
"_x" forall a. Semigroup a => a -> a -> a
<>) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> String
show
                forall a b. a -> (a -> b) -> b
& forall a. Int -> [a] -> [a]
take (forall (t :: * -> *) a. Foldable t => t a -> Int
length [Either Type CtrTypePattern]
cFields)
        bodyFor :: Either a CtrTypePattern -> (Name, Name) -> m Exp
bodyFor Left{} (Name
_, Name
v) = forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
v
        bodyFor (Right Node{}) (Name
f, Name
v) =
            [|
                HFunc
                    $( lamE
                        [varP varField]
                        [|Lens.Const $(recUpdE (varE varWhole) [pure (f, VarE varField)])|]
                     )
                    :*: $(varE v)
                |]
        bodyFor Either a CtrTypePattern
_ (Name, Name)
_ = forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"makeHContext only works for simple record fields"
        varWhole :: Name
varWhole = String -> Name
mkName String
"_whole"
        varField :: Name
varField = String -> Name
mkName String
"_field"
makeHContextCtr (Name
cName, ConstructorVariant
_, [Either Type CtrTypePattern
cField]) =
    forall (m :: * -> *).
Quote m =>
[m Pat] -> m Body -> [m Dec] -> m Clause
clause [forall (m :: * -> *). Quote m => Name -> [m Pat] -> m Pat
conP Name
cName [forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
cVar]] (forall (m :: * -> *). Quote m => m Exp -> m Body
normalB (Q Exp
n forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` Either Type CtrTypePattern -> Q Exp
bodyFor Either Type CtrTypePattern
cField)) []
    where
        n :: Q Exp
n = forall (m :: * -> *). Quote m => Name -> m Exp
conE Name
cName
        v :: Q Exp
v = forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
cVar
        bodyFor :: Either Type CtrTypePattern -> Q Exp
bodyFor Left{} = Q Exp
v
        bodyFor (Right Node{}) = [|HFunc (Lens.Const . $n) :*: $v|]
        bodyFor (Right GenEmbed{}) = Q Exp
embed
        bodyFor (Right FlatEmbed{}) = Q Exp
embed
        bodyFor Either Type CtrTypePattern
_ = forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"makeHContext only works for simple fields"
        embed :: Q Exp
embed =
            [|
                hmap
                    (const (Lens._1 . _HFunc . Lens.mapped . Lens._Wrapped Lens.%~ $n))
                    (hcontext $v)
                |]
        cVar :: Name
cVar = String -> Name
mkName String
"_c"
makeHContextCtr (Name, ConstructorVariant, [Either Type CtrTypePattern])
_ = forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"makeHContext: unsupported constructor"