aboutsummaryrefslogtreecommitdiff
path: root/src/HSVIS/AST.hs
diff options
context:
space:
mode:
Diffstat (limited to 'src/HSVIS/AST.hs')
-rw-r--r--src/HSVIS/AST.hs154
1 files changed, 70 insertions, 84 deletions
diff --git a/src/HSVIS/AST.hs b/src/HSVIS/AST.hs
index 7b05e19..a789c82 100644
--- a/src/HSVIS/AST.hs
+++ b/src/HSVIS/AST.hs
@@ -11,9 +11,10 @@
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE ConstrainedClassMethods #-}
module HSVIS.AST where
-import Data.Bifunctor (bimap, second)
+import Data.Bifunctor (bimap, first, second)
import qualified Data.Kind as DK
import Data.List.NonEmpty (NonEmpty)
import Data.Proxy
@@ -34,54 +35,16 @@ class HasExt f where
type HasXField f :: Bool
type HasECon f :: Bool
type ContainsData f :: [ASTType]
- extOf :: f s -> X f s
+ extOf :: HasXField f ~ 'True => f s -> X f s
extMap :: Proxy f -> Proxy s1 -> Proxy s2
- -> XMapperTelescope (TransitiveContainsData '[f]) s1 s2
- (EMapperTelescope (TransitiveContainsData '[f]) s1 s2
+ -> XMapperTelescope (f ': ContainsData f) s1 s2
+ (EMapperTelescope (f ': ContainsData f) s1 s2
(f s1 -> f s2))
type family If c a b where
If 'True a b = a
If 'False a b = b
-type family ASTShowPrereqs f s :: DK.Constraint where
- ASTShowPrereqs f s =
- (If (HasXField f) (Show (X f s)) (() :: DK.Constraint)
- ,If (HasECon f) (Show (E f s)) (() :: DK.Constraint)
- ,ASTShowPrereqsC (ContainsData f) s)
-
-type family ASTShowPrereqsC l s :: DK.Constraint where
- ASTShowPrereqsC '[] s = ()
- ASTShowPrereqsC (f ': fs) s = (Show (f s), ASTShowPrereqsC fs s)
-
-type family a && b where
- 'False && b = 'False
- 'True && b = b
-
-type family In x l where
- In x '[] = 'False
- In x (x ': ys) = 'True
- In x (_ ': ys) = In x ys
-
-type family Sublist l1 l2 where
- Sublist '[] l = 'True
- Sublist (x ': xs) l = In x l && Sublist xs l
-
-type family Union l1 l2 where
- Union '[] l = l
- Union (x ': xs) l = If (In x l) (Union xs l) (x ': Union xs l)
-
-type family MapContainsData l where
- MapContainsData '[] = '[]
- MapContainsData (f ': fs) = Union (ContainsData f) (MapContainsData fs)
-
-type family TransitiveContainsData fs where
- TransitiveContainsData fs = TransitiveContainsData' fs (Sublist (Union fs (MapContainsData fs)) fs)
-
-type family TransitiveContainsData' fs isfull where
- TransitiveContainsData' fs 'True = fs
- TransitiveContainsData' fs 'False = TransitiveContainsData (Union fs (MapContainsData fs))
-
type family XMapperTelescope fs s1 s2 a where
XMapperTelescope '[] s1 s2 a = a
XMapperTelescope (f ': fs) s1 s2 a =
@@ -93,7 +56,9 @@ type family EMapperTelescope fs s1 s2 a where
EMapperTelescope '[] s1 s2 a = a
EMapperTelescope (f ': fs) s1 s2 a =
If (HasECon f)
- ((X f s1 -> E f s1 -> f s2) -> EMapperTelescope fs s1 s2 a)
+ (If (HasXField f) (X f s1 -> E f s1 -> f s2)
+ (E f s1 -> f s2)
+ -> EMapperTelescope fs s1 s2 a)
(EMapperTelescope fs s1 s2 a)
@@ -103,19 +68,27 @@ newtype Name = Name String
data Program s = Program [DataDef s] [FunDef s]
deriving instance (Show (DataDef s), Show (FunDef s)) => Show (Program s)
-data DataDef s = DataDef (X DataDef s) Name [Name] [(Name, [Type s])]
-deriving instance ASTShowPrereqs DataDef s => Show (DataDef s)
+data DataDef s = DataDef (X DataDef s) Name [(X Type s, Name)] [(Name, [Type s])]
+deriving instance (Show (X DataDef s), Show (X Type s), Show (E Type s)) => Show (DataDef s)
-data FunDef s = FunDef (X FunDef s) Name (Maybe (Type s)) (NonEmpty (FunEq s))
-deriving instance ASTShowPrereqs FunDef s => Show (FunDef s)
+data FunDef s = FunDef (X FunDef s) Name (TypeSig s) (NonEmpty (FunEq s))
+deriving instance (Show (X FunDef s), Show (TypeSig s), Show (FunEq s)) => Show (FunDef s)
+
+data TypeSig s
+ = TypeSig (Type s)
+ | TypeSigExt !(E TypeSig s)
+deriving instance (Show (E TypeSig s), Show (Type s)) => Show (TypeSig s)
data FunEq s = FunEq (X FunEq s) Name [Pattern s] (RHS s)
-deriving instance ASTShowPrereqs FunEq s => Show (FunEq s)
+deriving instance (Show (X FunEq s), Show (Pattern s), Show (RHS s)) => Show (FunEq s)
data Kind s
= KType (X Kind s)
| KFun (X Kind s) (Kind s) (Kind s)
-deriving instance ASTShowPrereqs Kind s => Show (Kind s)
+
+ -- extension point
+ | KExt (X Kind s) !(E Kind s)
+deriving instance (Show (X Kind s), Show (E Kind s)) => Show (Kind s)
data Type s
= TApp (X Type s) (Type s) [Type s]
@@ -127,7 +100,7 @@ data Type s
-- extension point
| TExt (X Type s) !(E Type s)
-deriving instance ASTShowPrereqs Type s => Show (Type s)
+deriving instance (Show (X Type s), Show (E Type s)) => Show (Type s)
data Pattern s
= PWildcard (X Pattern s)
@@ -137,12 +110,12 @@ data Pattern s
| POp (X Pattern s) (Pattern s) Operator (Pattern s)
| PList (X Pattern s) [Pattern s]
| PTup (X Pattern s) [Pattern s]
-deriving instance ASTShowPrereqs Pattern s => Show (Pattern s)
+deriving instance (Show (X Pattern s)) => Show (Pattern s)
data RHS s
= Guarded (X RHS s) [(Expr s, Expr s)] -- currently not parsed
| Plain (X RHS s) (Expr s)
-deriving instance ASTShowPrereqs RHS s => Show (RHS s)
+deriving instance (Show (X RHS s), Show (Expr s)) => Show (RHS s)
data Expr s
= ELit (X Expr s) Literal
@@ -156,7 +129,7 @@ data Expr s
| ECase (X Expr s) (Expr s) [(Pattern s, RHS s)]
| ELet (X Expr s) [FunDef s] (Expr s)
| EError (X Expr s)
-deriving instance ASTShowPrereqs Expr s => Show (Expr s)
+deriving instance (Show (X Expr s), Show (Pattern s), Show (RHS s), Show (FunDef s)) => Show (Expr s)
data Literal = LInt Integer | LFloat Rational | LChar Char | LString String
deriving (Show)
@@ -174,39 +147,51 @@ instance HasExt DataDef where
type ContainsData DataDef = '[Type]
extOf (DataDef x _ _ _) = x
extMap _ ps1 ps2 fdd fty gty (DataDef x n ps cs) =
- DataDef (fdd x) n ps (map (second (map (extMap (Proxy @Type) ps1 ps2 fty gty))) cs)
+ DataDef (fdd x) n (map (first fty) ps) (map (second (map (extMap (Proxy @Type) ps1 ps2 fty gty))) cs)
instance HasExt FunDef where
type HasXField FunDef = 'True
type HasECon FunDef = 'False
- type ContainsData FunDef = '[Type, FunEq]
+ type ContainsData FunDef = '[TypeSig, FunEq, Type, Pattern, RHS, Expr]
extOf (FunDef x _ _ _) = x
- extMap _ ps1 ps2 ffd ffe frh fty fpa fex gty (FunDef x n msig es) =
- FunDef (ffd x) n (extMap (Proxy @Type) ps1 ps2 fty gty <$> msig)
- (fmap (extMap (Proxy @FunEq) ps1 ps2 frh ffd fpa fex fty ffe gty) es)
+ extMap _ ps1 ps2 ffd ffe fty fpa frh fex gts gty (FunDef x n sig es) =
+ FunDef (ffd x) n
+ (extMap (Proxy @TypeSig) ps1 ps2 fty gts gty sig)
+ (fmap (extMap (Proxy @FunEq) ps1 ps2 ffe ffd fty fpa frh fex gts gty) es)
+
+instance HasExt TypeSig where
+ type HasXField TypeSig = 'False
+ type HasECon TypeSig = 'True
+ type ContainsData TypeSig = '[Type]
+ extOf _ = undefined
+ extMap _ ps1 ps2 fty _ gty (TypeSig ty) =
+ TypeSig (extMap (Proxy @Type) ps1 ps2 fty gty ty)
+ extMap _ _ _ _ gts _ (TypeSigExt e) = gts e
instance HasExt FunEq where
type HasXField FunEq = 'True
type HasECon FunEq = 'False
- type ContainsData FunEq = '[Pattern, RHS]
+ type ContainsData FunEq = '[FunDef, TypeSig, Type, Pattern, RHS, Expr]
extOf (FunEq x _ _ _) = x
- extMap _ ps1 ps2 frh ffd fpa fex fty ffe gty (FunEq x n ps rhs) =
+ extMap _ ps1 ps2 ffe ffd fty fpa frh fex gts gty (FunEq x n ps rhs) =
FunEq (ffe x) n (map (extMap (Proxy @Pattern) ps1 ps2 fpa) ps)
- (extMap (Proxy @RHS) ps1 ps2 frh ffd fpa fex fty ffe gty rhs)
+ (extMap (Proxy @RHS) ps1 ps2 frh ffd ffe fty fpa fex gts gty rhs)
instance HasExt Kind where
type HasXField Kind = 'True
- type HasECon Kind = 'False
- type ContainsData Kind = '[Kind]
+ type HasECon Kind = 'True
+ type ContainsData Kind = '[]
extOf (KType x) = x
extOf (KFun x _ _) = x
- extMap _ _ _ f (KType x) = KType (f x)
- extMap p ps1 ps2 f (KFun x a b) = KFun (f x) (extMap p ps1 ps2 f a) (extMap p ps1 ps2 f b)
+ extOf (KExt x _) = x
+ extMap _ _ _ f _ (KType x) = KType (f x)
+ extMap p ps1 ps2 f g (KFun x a b) = KFun (f x) (extMap p ps1 ps2 f g a) (extMap p ps1 ps2 f g b)
+ extMap _ _ _ _ g (KExt x a) = g x a
instance HasExt Type where
type HasXField Type = 'True
type HasECon Type = 'True
- type ContainsData Type = '[Type]
+ type ContainsData Type = '[]
extOf (TApp x _ _) = x
extOf (TTup x _) = x
extOf (TList x _) = x
@@ -226,7 +211,7 @@ instance HasExt Type where
instance HasExt Pattern where
type HasXField Pattern = 'True
type HasECon Pattern = 'False
- type ContainsData Pattern = '[Pattern]
+ type ContainsData Pattern = '[]
extOf (PWildcard x) = x
extOf (PVar x _) = x
extOf (PAs x _ _) = x
@@ -246,21 +231,22 @@ instance HasExt Pattern where
instance HasExt RHS where
type HasXField RHS = 'True
type HasECon RHS = 'False
- type ContainsData RHS = '[Expr]
+ type ContainsData RHS = '[FunDef, TypeSig, FunEq, Type, Pattern, Expr]
extOf (Guarded x _) = x
extOf (Plain x _) = x
- extMap _ ps1 ps2 frh ffd fpa fex fty ffe gty (Guarded x l) =
- Guarded (frh x) (map (bimap (extMap (Proxy @Expr) ps1 ps2 frh ffd fpa fex fty ffe gty)
- (extMap (Proxy @Expr) ps1 ps2 frh ffd fpa fex fty ffe gty))
- l)
- extMap _ ps1 ps2 frh ffd fpa fex fty ffe gty (Plain x e) =
- Plain (frh x) (extMap (Proxy @Expr) ps1 ps2 frh ffd fpa fex fty ffe gty e)
+ extMap _ ps1 ps2 frh ffd ffe fty fpa fex gts gty (Guarded x l) =
+ Guarded (frh x)
+ (map (bimap (extMap (Proxy @Expr) ps1 ps2 fex ffd ffe fty fpa frh gts gty)
+ (extMap (Proxy @Expr) ps1 ps2 fex ffd ffe fty fpa frh gts gty))
+ l)
+ extMap _ ps1 ps2 frh ffd ffe fty fpa fex gts gty (Plain x e) =
+ Plain (frh x) (extMap (Proxy @Expr) ps1 ps2 fex ffd ffe fty fpa frh gts gty e)
instance HasExt Expr where
type HasXField Expr = 'True
type HasECon Expr = 'False
- type ContainsData Expr = '[Expr, Pattern, RHS, FunDef]
+ type ContainsData Expr = '[FunDef, TypeSig, FunEq, Type, Pattern, RHS]
extOf (ELit x _) = x
extOf (EVar x _) = x
extOf (ECon x _) = x
@@ -273,18 +259,18 @@ instance HasExt Expr where
extOf (ELet x _ _) = x
extOf (EError x) = x
- extMap p ps1 ps2 frh ffd fpa fex fty ffe gty = \case
+ extMap p ps1 ps2 fex ffd ffe fty fpa frh gts gty = \case
ELit x l -> ELit (fex x) l
EVar x n -> EVar (fex x) n
ECon x n -> ECon (fex x) n
- EList x es -> EList (fex x) (map (extMap p ps1 ps2 frh ffd fpa fex fty ffe gty) es)
- ETup x es -> ETup (fex x) (map (extMap p ps1 ps2 frh ffd fpa fex fty ffe gty) es)
- EApp x a es -> EApp (fex x) (extMap p ps1 ps2 frh ffd fpa fex fty ffe gty a) (map (extMap p ps1 ps2 frh ffd fpa fex fty ffe gty) es)
- EOp x a n b -> EOp (fex x) (extMap p ps1 ps2 frh ffd fpa fex fty ffe gty a) n (extMap p ps1 ps2 frh ffd fpa fex fty ffe gty b)
- EIf x a b c -> EIf (fex x) (extMap p ps1 ps2 frh ffd fpa fex fty ffe gty a) (extMap p ps1 ps2 frh ffd fpa fex fty ffe gty b) (extMap p ps1 ps2 frh ffd fpa fex fty ffe gty c)
- ECase x a l -> ECase (fex x) (extMap p ps1 ps2 frh ffd fpa fex fty ffe gty a)
+ EList x es -> EList (fex x) (map (extMap p ps1 ps2 fex ffd ffe fty fpa frh gts gty) es)
+ ETup x es -> ETup (fex x) (map (extMap p ps1 ps2 fex ffd ffe fty fpa frh gts gty) es)
+ EApp x a es -> EApp (fex x) (extMap p ps1 ps2 fex ffd ffe fty fpa frh gts gty a) (map (extMap p ps1 ps2 fex ffd ffe fty fpa frh gts gty) es)
+ EOp x a n b -> EOp (fex x) (extMap p ps1 ps2 fex ffd ffe fty fpa frh gts gty a) n (extMap p ps1 ps2 fex ffd ffe fty fpa frh gts gty b)
+ EIf x a b c -> EIf (fex x) (extMap p ps1 ps2 fex ffd ffe fty fpa frh gts gty a) (extMap p ps1 ps2 fex ffd ffe fty fpa frh gts gty b) (extMap p ps1 ps2 fex ffd ffe fty fpa frh gts gty c)
+ ECase x a l -> ECase (fex x) (extMap p ps1 ps2 fex ffd ffe fty fpa frh gts gty a)
(map (bimap (extMap (Proxy @Pattern) ps1 ps2 fpa)
- (extMap (Proxy @RHS) ps1 ps2 frh ffd fpa fex fty ffe gty))
+ (extMap (Proxy @RHS) ps1 ps2 frh ffd ffe fty fpa fex gts gty))
l)
- ELet x as b -> ELet (fex x) (map (extMap (Proxy @FunDef) ps1 ps2 ffd ffe frh fty fpa fex gty) as) (extMap p ps1 ps2 frh ffd fpa fex fty ffe gty b)
+ ELet x as b -> ELet (fex x) (map (extMap (Proxy @FunDef) ps1 ps2 ffd ffe fty fpa frh fex gts gty) as) (extMap p ps1 ps2 fex ffd ffe fty fpa frh gts gty b)
EError x -> EError (fex x)
generated by cgit v1.2.3-70-g09d2 (git 2.47.0) at 2024-11-01 06:33:18 +0100