{-# 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"