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