{-# LANGUAGE TemplateHaskell, EmptyCase #-}

-- | Generate 'HNodes' instances via @TemplateHaskell@

module Hyper.TH.Nodes
    ( makeHNodes
    ) where

import qualified Control.Lens as Lens
import           GHC.Generics (V1)
import           Hyper.Class.Nodes (HNodes(..), HWitness(..))
import           Hyper.TH.Internal.Utils
import           Language.Haskell.TH
import qualified Language.Haskell.TH.Datatype as D

import           Hyper.Internal.Prelude

-- | Generate a 'HNodes' instance
makeHNodes :: Name -> DecsQ
makeHNodes :: Name -> DecsQ
makeHNodes 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
makeHNodesForType

makeHNodesForType :: TypeInfo -> DecsQ
makeHNodesForType :: TypeInfo -> DecsQ
makeHNodesForType TypeInfo
info =
    [ CxtQ -> TypeQ -> [DecQ] -> DecQ
instanceD ([Pred] -> CxtQ
simplifyContext (TypeInfo -> [Pred]
makeContext TypeInfo
info)) [t|HNodes $(pure (tiInstance info))|]
        [ Name -> Maybe [Q TyVarBndrUnit] -> [TypeQ] -> TypeQ -> DecQ
D.tySynInstDCompat
            ''HNodesConstraint
            ([Q TyVarBndrUnit] -> Maybe [Q TyVarBndrUnit]
forall a. a -> Maybe a
Just [TyVarBndrUnit -> Q TyVarBndrUnit
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Name -> TyVarBndrUnit
plainTV Name
constraintVar)])
            [Pred -> TypeQ
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TypeInfo -> Pred
tiInstance TypeInfo
info), TypeQ
c]
            (CxtQ
nodesConstraint CxtQ -> ([Pred] -> CxtQ) -> CxtQ
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= [Pred] -> CxtQ
simplifyContext CxtQ -> ([Pred] -> Pred) -> TypeQ
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> [Pred] -> Pred
forall (t :: * -> *). Foldable t => t Pred -> Pred
toTuple)
        , Name -> Maybe [Q TyVarBndrUnit] -> [TypeQ] -> TypeQ -> DecQ
D.tySynInstDCompat ''HWitnessType Maybe [Q TyVarBndrUnit]
forall a. Maybe a
Nothing [Pred -> TypeQ
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TypeInfo -> Pred
tiInstance TypeInfo
info)] TypeQ
witType
        , Name -> Inline -> RuleMatch -> Phases -> Pragma
InlineP 'hLiftConstraint 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 'hLiftConstraint (NodeWitnesses -> [ClauseQ]
makeHLiftConstraints NodeWitnesses
wit)
        ]
    ] [DecQ] -> [DecQ] -> [DecQ]
forall a. Semigroup a => a -> a -> a
<> [DecQ]
witDecs
    [DecQ] -> ([DecQ] -> DecsQ) -> DecsQ
forall a b. a -> (a -> b) -> b
& [DecQ] -> DecsQ
forall (t :: * -> *) (f :: * -> *) a.
(Traversable t, Applicative f) =>
t (f a) -> f (t a)
sequenceA
    where
        (TypeQ
witType, [DecQ]
witDecs)
            | [Pred -> Q Con] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Pred -> Q Con]
nodeOfCons = ([t|V1|], [])
            | Bool
otherwise =
                ( TypeInfo -> [TyVarBndrUnit]
tiParams TypeInfo
info [TyVarBndrUnit] -> (TyVarBndrUnit -> TypeQ) -> [TypeQ]
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> Name -> TypeQ
varT (Name -> TypeQ)
-> (TyVarBndrUnit -> Name) -> TyVarBndrUnit -> TypeQ
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TyVarBndrUnit -> Name
forall flag. TyVarBndrUnit -> Name
D.tvName [TypeQ] -> ([TypeQ] -> TypeQ) -> TypeQ
forall a b. a -> (a -> b) -> b
& (TypeQ -> TypeQ -> TypeQ) -> TypeQ -> [TypeQ] -> TypeQ
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl TypeQ -> TypeQ -> TypeQ
appT (Name -> TypeQ
conT Name
witTypeName)
                , [CxtQ
-> Name
-> [TyVarBndrUnit]
-> Maybe Pred
-> [Q Con]
-> [DerivClauseQ]
-> DecQ
dataD ([Pred] -> CxtQ
forall (f :: * -> *) a. Applicative f => a -> f a
pure []) Name
witTypeName
                    (TypeInfo -> [TyVarBndrUnit]
tiParams TypeInfo
info [TyVarBndrUnit] -> [TyVarBndrUnit] -> [TyVarBndrUnit]
forall a. Semigroup a => a -> a -> a
<> [Name -> TyVarBndrUnit
plainTV (String -> Name
mkName String
"node")])
                    Maybe Pred
forall a. Maybe a
Nothing ([Pred -> Q Con]
nodeOfCons [Pred -> Q Con] -> ((Pred -> Q Con) -> Q Con) -> [Q Con]
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> (TypeQ
witType TypeQ -> (Pred -> Q Con) -> Q Con
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=)) []
                    ]
                )
            where
                witTypeName :: Name
witTypeName = String -> Name
mkName (String
"W_" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Name -> String
niceName (TypeInfo -> Name
tiName TypeInfo
info))
        ([Pred -> Q Con]
nodeOfCons, NodeWitnesses
wit) = TypeInfo -> ([Pred -> Q Con], NodeWitnesses)
makeNodeOf TypeInfo
info
        constraintVar :: Name
constraintVar = String -> Name
mkName String
"constraint"
        c :: TypeQ
c = Name -> TypeQ
varT Name
constraintVar
        contents :: TypeContents
contents = TypeInfo -> TypeContents
childrenTypes TypeInfo
info
        nodesConstraint :: CxtQ
nodesConstraint =
            (TypeContents -> Set Pred
tcChildren TypeContents
contents Set Pred -> Getting (Endo [Pred]) (Set Pred) Pred -> [Pred]
forall s a. s -> Getting (Endo [a]) s a -> [a]
^.. Getting (Endo [Pred]) (Set Pred) Pred
forall (f :: * -> *) a. Foldable f => IndexedFold Int (f a) a
Lens.folded [Pred] -> (Pred -> TypeQ) -> [TypeQ]
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> (TypeQ
c TypeQ -> TypeQ -> TypeQ
`appT`) (TypeQ -> TypeQ) -> (Pred -> TypeQ) -> Pred -> TypeQ
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Pred -> TypeQ
forall (f :: * -> *) a. Applicative f => a -> f a
pure)
            [TypeQ] -> [TypeQ] -> [TypeQ]
forall a. Semigroup a => a -> a -> a
<> (TypeContents -> Set Pred
tcEmbeds TypeContents
contents Set Pred -> Getting (Endo [Pred]) (Set Pred) Pred -> [Pred]
forall s a. s -> Getting (Endo [a]) s a -> [a]
^.. Getting (Endo [Pred]) (Set Pred) Pred
forall (f :: * -> *) a. Foldable f => IndexedFold Int (f a) a
Lens.folded [Pred] -> (Pred -> TypeQ) -> [TypeQ]
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \Pred
x -> [t|HNodesConstraint $(pure x) $c|])
            [TypeQ] -> [TypeQ] -> [TypeQ]
forall a. Semigroup a => a -> a -> a
<> (TypeContents -> Set Pred
tcOthers TypeContents
contents Set Pred -> Getting (Endo [Pred]) (Set Pred) Pred -> [Pred]
forall s a. s -> Getting (Endo [a]) s a -> [a]
^.. Getting (Endo [Pred]) (Set Pred) Pred
forall (f :: * -> *) a. Foldable f => IndexedFold Int (f a) a
Lens.folded [Pred] -> (Pred -> TypeQ) -> [TypeQ]
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> Pred -> TypeQ
forall (f :: * -> *) a. Applicative f => a -> f a
pure)
            [TypeQ] -> ([TypeQ] -> CxtQ) -> CxtQ
forall a b. a -> (a -> b) -> b
& [TypeQ] -> CxtQ
forall (t :: * -> *) (f :: * -> *) a.
(Traversable t, Applicative f) =>
t (f a) -> f (t a)
sequenceA

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 (InContainer Pred
_ CtrTypePattern
pat) = CtrTypePattern -> [Pred]
ctxForPat CtrTypePattern
pat
        ctxForPat (GenEmbed Pred
t) = [Name -> Pred
ConT ''HNodes Pred -> Pred -> Pred
`AppT` Pred
t]
        ctxForPat CtrTypePattern
_ = []

makeHLiftConstraints :: NodeWitnesses -> [Q Clause]
makeHLiftConstraints :: NodeWitnesses -> [ClauseQ]
makeHLiftConstraints NodeWitnesses
wit
    | [ClauseQ] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [ClauseQ]
clauses = [[PatQ] -> BodyQ -> [DecQ] -> ClauseQ
clause [] (ExpQ -> BodyQ
normalB [|\case|]) []]
    | Bool
otherwise = [ClauseQ]
clauses
    where
        clauses :: [ClauseQ]
clauses = (NodeWitnesses -> [Name]
nodeWitCtrs NodeWitnesses
wit [Name] -> (Name -> ClauseQ) -> [ClauseQ]
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> Name -> ClauseQ
liftNode) [ClauseQ] -> [ClauseQ] -> [ClauseQ]
forall a. Semigroup a => a -> a -> a
<> (NodeWitnesses -> [Name]
embedWitCtrs NodeWitnesses
wit [Name] -> (Name -> ClauseQ) -> [ClauseQ]
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> Name -> ClauseQ
liftEmbed)
        liftNode :: Name -> ClauseQ
liftNode Name
x = [PatQ] -> BodyQ -> [DecQ] -> ClauseQ
clause [Name -> [PatQ] -> PatQ
conP 'HWitness [Name -> [PatQ] -> PatQ
conP Name
x []]] (ExpQ -> BodyQ
normalB [|\_ r -> r|]) []
        liftEmbed :: Name -> ClauseQ
liftEmbed Name
x =
            [PatQ] -> BodyQ -> [DecQ] -> ClauseQ
clause [Name -> [PatQ] -> PatQ
conP 'HWitness [Name -> [PatQ] -> PatQ
conP Name
x [Name -> PatQ
varP Name
witVar]]]
            (ExpQ -> BodyQ
normalB [|hLiftConstraint $(varE witVar)|]) []
        witVar :: Name
        witVar :: Name
witVar = String -> Name
mkName String
"witness"