{-# LANGUAGE TemplateHaskell #-}
{-# OPTIONS_GHC -Wno-incomplete-patterns #-}
module Symantic.Syntaxes.Reify where
import Control.Monad (Monad (..))
import Data.Function qualified as Fun
import Language.Haskell.TH qualified as TH
import Symantic.Syntaxes.Classes (Abstractable (..), Unabstractable (..))
data ReifyReflect repr meta a = ReifyReflect
{
forall (repr :: * -> *) meta a.
ReifyReflect repr meta a -> meta -> repr a
reify :: meta -> repr a
,
forall (repr :: * -> *) meta a.
ReifyReflect repr meta a -> repr a -> meta
reflect :: repr a -> meta
}
base :: ReifyReflect repr (repr a) a
base :: forall (repr :: * -> *) a. ReifyReflect repr (repr a) a
base = ReifyReflect :: forall (repr :: * -> *) meta a.
(meta -> repr a) -> (repr a -> meta) -> ReifyReflect repr meta a
ReifyReflect{reify :: repr a -> repr a
reify = repr a -> repr a
forall a. a -> a
Fun.id, reflect :: repr a -> repr a
reflect = repr a -> repr a
forall a. a -> a
Fun.id}
infixr 8 -->
(-->) ::
Abstractable repr =>
ReifyReflect repr m1 o1 ->
ReifyReflect repr m2 o2 ->
ReifyReflect repr (m1 -> m2) (o1 -> o2)
ReifyReflect repr m1 o1
r1 --> :: forall (repr :: * -> *) m1 o1 m2 o2.
Abstractable repr =>
ReifyReflect repr m1 o1
-> ReifyReflect repr m2 o2
-> ReifyReflect repr (m1 -> m2) (o1 -> o2)
--> ReifyReflect repr m2 o2
r2 =
ReifyReflect :: forall (repr :: * -> *) meta a.
(meta -> repr a) -> (repr a -> meta) -> ReifyReflect repr meta a
ReifyReflect
{ reify :: (m1 -> m2) -> repr (o1 -> o2)
reify = \m1 -> m2
meta -> (repr o1 -> repr o2) -> repr (o1 -> o2)
forall (sem :: * -> *) a b.
Abstractable sem =>
(sem a -> sem b) -> sem (a -> b)
lam (ReifyReflect repr m2 o2 -> m2 -> repr o2
forall (repr :: * -> *) meta a.
ReifyReflect repr meta a -> meta -> repr a
reify ReifyReflect repr m2 o2
r2 (m2 -> repr o2) -> (repr o1 -> m2) -> repr o1 -> repr o2
forall b c a. (b -> c) -> (a -> b) -> a -> c
Fun.. m1 -> m2
meta (m1 -> m2) -> (repr o1 -> m1) -> repr o1 -> m2
forall b c a. (b -> c) -> (a -> b) -> a -> c
Fun.. ReifyReflect repr m1 o1 -> repr o1 -> m1
forall (repr :: * -> *) meta a.
ReifyReflect repr meta a -> repr a -> meta
reflect ReifyReflect repr m1 o1
r1)
, reflect :: repr (o1 -> o2) -> m1 -> m2
reflect = \repr (o1 -> o2)
repr -> ReifyReflect repr m2 o2 -> repr o2 -> m2
forall (repr :: * -> *) meta a.
ReifyReflect repr meta a -> repr a -> meta
reflect ReifyReflect repr m2 o2
r2 (repr o2 -> m2) -> (m1 -> repr o2) -> m1 -> m2
forall b c a. (b -> c) -> (a -> b) -> a -> c
Fun.. repr (o1 -> o2) -> repr o1 -> repr o2
forall (sem :: * -> *) a b.
Unabstractable sem =>
sem (a -> b) -> sem a -> sem b
(.@) repr (o1 -> o2)
repr (repr o1 -> repr o2) -> (m1 -> repr o1) -> m1 -> repr o2
forall b c a. (b -> c) -> (a -> b) -> a -> c
Fun.. ReifyReflect repr m1 o1 -> m1 -> repr o1
forall (repr :: * -> *) meta a.
ReifyReflect repr meta a -> meta -> repr a
reify ReifyReflect repr m1 o1
r1
}
reifyTH :: TH.Name -> TH.Q TH.Exp
reifyTH :: Name -> Q Exp
reifyTH Name
name = do
Info
info <- Name -> Q Info
TH.reify Name
name
case Info
info of
TH.VarI Name
n (TH.ForallT [TyVarBndr Specificity]
_vs Cxt
_ctx Type
ty) Maybe Dec
_dec ->
[|reify $(genReifyReflect ty) $(return (TH.VarE n))|]
where
genReifyReflect :: Type -> m Exp
genReifyReflect (TH.AppT (TH.AppT Type
TH.ArrowT Type
a) Type
b) = [|$(genReifyReflect a) --> $(genReifyReflect b)|]
genReifyReflect TH.VarT{} = [|base|]