{-# 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 Q TypeInfo -> (TypeInfo -> DecsQ) -> DecsQ
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 =
    CxtQ -> TypeQ -> [DecQ] -> DecQ
instanceD ([Pred] -> CxtQ
simplifyContext (TypeInfo -> [Pred]
makeContext TypeInfo
info)) [t|HContext $(pure (tiInstance info))|]
    [ Name -> Inline -> RuleMatch -> Phases -> Pragma
InlineP 'hcontext Inline
Inline RuleMatch
FunLike Phases
AllPhases Pragma -> (Pragma -> Dec) -> Dec
forall a b. a -> (a -> b) -> b
& Pragma -> Dec
PragmaD Dec -> (Dec -> DecQ) -> DecQ
forall a b. a -> (a -> b) -> b
& Dec -> DecQ
forall (f :: * -> *) a. Applicative f => a -> f a
pure
    , Name -> [ClauseQ] -> DecQ
funD 'hcontext (TypeInfo
-> [(Name, ConstructorVariant, [Either Pred CtrTypePattern])]
tiConstructors TypeInfo
info [(Name, ConstructorVariant, [Either Pred CtrTypePattern])]
-> ((Name, ConstructorVariant, [Either Pred CtrTypePattern])
    -> ClauseQ)
-> [ClauseQ]
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> (Name, ConstructorVariant, [Either Pred CtrTypePattern]) -> ClauseQ
makeHContextCtr)
    ]
    DecQ -> (Dec -> [Dec]) -> DecsQ
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> (Dec -> [Dec] -> [Dec]
forall a. a -> [a] -> [a]
:[])

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

makeHContextCtr ::
    (Name, ConstructorVariant, [Either Type CtrTypePattern]) -> Q Clause
makeHContextCtr :: (Name, ConstructorVariant, [Either Pred CtrTypePattern]) -> ClauseQ
makeHContextCtr (Name
cName, ConstructorVariant
_, []) =
    [PatQ] -> BodyQ -> [DecQ] -> ClauseQ
clause [Name -> [PatQ] -> PatQ
conP Name
cName []] (ExpQ -> BodyQ
normalB (Name -> ExpQ
conE Name
cName)) []
makeHContextCtr (Name
cName, RecordConstructor [Name]
fieldNames, [Either Pred CtrTypePattern]
cFields) =
    [PatQ] -> BodyQ -> [DecQ] -> ClauseQ
clause [Name
varWhole Name -> PatQ -> PatQ
`asP` Name -> [PatQ] -> PatQ
conP Name
cName ([Name]
cVars [Name] -> (Name -> PatQ) -> [PatQ]
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> Name -> PatQ
varP)]
    (ExpQ -> BodyQ
normalB ((ExpQ -> ExpQ -> ExpQ) -> ExpQ -> [ExpQ] -> ExpQ
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl ExpQ -> ExpQ -> ExpQ
appE (Name -> ExpQ
conE Name
cName) ((Either Pred CtrTypePattern -> (Name, Name) -> ExpQ)
-> [Either Pred CtrTypePattern] -> [(Name, Name)] -> [ExpQ]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Either Pred CtrTypePattern -> (Name, Name) -> ExpQ
forall a. Either a CtrTypePattern -> (Name, Name) -> ExpQ
bodyFor [Either Pred CtrTypePattern]
cFields ([Name] -> [Name] -> [(Name, Name)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Name]
fieldNames [Name]
cVars)))) []
    where
        cVars :: [Name]
cVars =
            [(Int
0 :: Int) ..] [Int] -> (Int -> String) -> [String]
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> Int -> String
forall a. Show a => a -> String
show [String] -> (String -> String) -> [String]
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> (String
"_x" String -> String -> String
forall a. Semigroup a => a -> a -> a
<>) [String] -> (String -> Name) -> [Name]
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> String -> Name
mkName
            [Name] -> ([Name] -> [Name]) -> [Name]
forall a b. a -> (a -> b) -> b
& Int -> [Name] -> [Name]
forall a. Int -> [a] -> [a]
take ([Either Pred CtrTypePattern] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Either Pred CtrTypePattern]
cFields)
        bodyFor :: Either a CtrTypePattern -> (Name, Name) -> ExpQ
bodyFor Left{} (Name
_, Name
v) = Name -> ExpQ
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)
_ = String -> ExpQ
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 Pred CtrTypePattern
cField]) =
    [PatQ] -> BodyQ -> [DecQ] -> ClauseQ
clause [Name -> [PatQ] -> PatQ
conP Name
cName [Name -> PatQ
varP Name
cVar]] (ExpQ -> BodyQ
normalB (ExpQ
n ExpQ -> ExpQ -> ExpQ
`appE` Either Pred CtrTypePattern -> ExpQ
bodyFor Either Pred CtrTypePattern
cField)) []
    where
        n :: ExpQ
n = Name -> ExpQ
conE Name
cName
        v :: ExpQ
v = Name -> ExpQ
varE Name
cVar
        bodyFor :: Either Pred CtrTypePattern -> ExpQ
bodyFor Left{} = ExpQ
v
        bodyFor (Right Node{}) = [|HFunc (Lens.Const . $n) :*: $v|]
        bodyFor (Right GenEmbed{}) = ExpQ
embed
        bodyFor (Right FlatEmbed{}) = ExpQ
embed
        bodyFor Either Pred CtrTypePattern
_ = String -> ExpQ
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"makeHContext only works for simple fields"
        embed :: ExpQ
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 Pred CtrTypePattern])
_ = String -> ClauseQ
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"makeHContext: unsupported constructor"