mirror of
https://github.com/github/semantic.git
synced 2024-12-27 00:44:57 +03:00
Specialize Type, Constraint, Solution, & Substitution to Name.
This commit is contained in:
parent
814f6fe8cf
commit
18bc19a04e
@ -51,7 +51,7 @@ data Monotype name f a
|
|||||||
|
|
||||||
infixr 0 :->
|
infixr 0 :->
|
||||||
|
|
||||||
type Type name = Term (Monotype name) Meta
|
type Type = Term (Monotype Name) Meta
|
||||||
|
|
||||||
-- FIXME: Union the effects/annotations on the operands.
|
-- FIXME: Union the effects/annotations on the operands.
|
||||||
|
|
||||||
@ -100,12 +100,12 @@ typecheckingFlowInsensitive
|
|||||||
:: Ord (term Name)
|
:: Ord (term Name)
|
||||||
=> (forall sig m
|
=> (forall sig m
|
||||||
. (Carrier sig m, Member (Reader Path.AbsRelFile) sig, Member (Reader Span) sig, MonadFail m)
|
. (Carrier sig m, Member (Reader Path.AbsRelFile) sig, Member (Reader Span) sig, MonadFail m)
|
||||||
=> Analysis term Name Name (Type Name) m
|
=> Analysis term Name Name Type m
|
||||||
-> (term Name -> m (Type Name))
|
-> (term Name -> m Type)
|
||||||
-> (term Name -> m (Type Name))
|
-> (term Name -> m Type)
|
||||||
)
|
)
|
||||||
-> [File (term Name)]
|
-> [File (term Name)]
|
||||||
-> ( Heap Name (Type Name)
|
-> ( Heap Name Type
|
||||||
, [File (Either (Path.AbsRelFile, Span, String) (Term (Polytype :+: Monotype Name) Void))]
|
, [File (Either (Path.AbsRelFile, Span, String) (Term (Polytype :+: Monotype Name) Void))]
|
||||||
)
|
)
|
||||||
typecheckingFlowInsensitive eval
|
typecheckingFlowInsensitive eval
|
||||||
@ -119,47 +119,47 @@ runFile
|
|||||||
:: ( Carrier sig m
|
:: ( Carrier sig m
|
||||||
, Effect sig
|
, Effect sig
|
||||||
, Member Fresh sig
|
, Member Fresh sig
|
||||||
, Member (State (Heap Name (Type Name))) sig
|
, Member (State (Heap Name Type)) sig
|
||||||
, Ord (term Name)
|
, Ord (term Name)
|
||||||
)
|
)
|
||||||
=> (forall sig m
|
=> (forall sig m
|
||||||
. (Carrier sig m, Member (Reader Path.AbsRelFile) sig, Member (Reader Span) sig, MonadFail m)
|
. (Carrier sig m, Member (Reader Path.AbsRelFile) sig, Member (Reader Span) sig, MonadFail m)
|
||||||
=> Analysis term Name Name (Type Name) m
|
=> Analysis term Name Name Type m
|
||||||
-> (term Name -> m (Type Name))
|
-> (term Name -> m Type)
|
||||||
-> (term Name -> m (Type Name))
|
-> (term Name -> m Type)
|
||||||
)
|
)
|
||||||
-> File (term Name)
|
-> File (term Name)
|
||||||
-> m (File (Either (Path.AbsRelFile, Span, String) (Type Name)))
|
-> m (File (Either (Path.AbsRelFile, Span, String) Type))
|
||||||
runFile eval file = traverse run file
|
runFile eval file = traverse run file
|
||||||
where run
|
where run
|
||||||
= (\ m -> do
|
= (\ m -> do
|
||||||
(subst, t) <- m
|
(subst, t) <- m
|
||||||
modify @(Heap Name (Type Name)) (fmap (Set.map (substAll subst)))
|
modify @(Heap Name Type) (fmap (Set.map (substAll subst)))
|
||||||
pure (substAll subst <$> t))
|
pure (substAll subst <$> t))
|
||||||
. runState (mempty :: (Substitution name))
|
. runState @Substitution mempty
|
||||||
. runReader (filePath file)
|
. runReader (filePath file)
|
||||||
. runReader (fileSpan file)
|
. runReader (fileSpan file)
|
||||||
. runEnv @Name
|
. runEnv @Name
|
||||||
. runFail
|
. runFail
|
||||||
. (\ m -> do
|
. (\ m -> do
|
||||||
(cs, t) <- m
|
(cs, t) <- m
|
||||||
t <$ solve @Name cs)
|
t <$ solve cs)
|
||||||
. runState (Set.empty :: Set.Set (Constraint name))
|
. runState @(Set.Set Constraint) mempty
|
||||||
. (\ m -> do
|
. (\ m -> do
|
||||||
v <- meta
|
v <- meta
|
||||||
bs <- m
|
bs <- m
|
||||||
v <$ for_ bs (unify v))
|
v <$ for_ bs (unify v))
|
||||||
. convergeTerm (Proxy @Name) (A.runHeap @Name @(Type Name) . fix (cacheTerm . eval typecheckingAnalysis))
|
. convergeTerm (Proxy @Name) (A.runHeap @Name @Type . fix (cacheTerm . eval typecheckingAnalysis))
|
||||||
|
|
||||||
typecheckingAnalysis
|
typecheckingAnalysis
|
||||||
:: ( Alternative m
|
:: ( Alternative m
|
||||||
, Carrier sig m
|
, Carrier sig m
|
||||||
, Member (Env Name Name) sig
|
, Member (Env Name Name) sig
|
||||||
, Member Fresh sig
|
, Member Fresh sig
|
||||||
, Member (A.Heap Name (Type Name)) sig
|
, Member (A.Heap Name Type) sig
|
||||||
, Member (State (Set.Set (Constraint Name))) sig
|
, Member (State (Set.Set Constraint)) sig
|
||||||
)
|
)
|
||||||
=> Analysis term Name Name (Type Name) m
|
=> Analysis term Name Name Type m
|
||||||
typecheckingAnalysis = Analysis{..}
|
typecheckingAnalysis = Analysis{..}
|
||||||
where abstract eval name body = do
|
where abstract eval name body = do
|
||||||
-- FIXME: construct the associated scope
|
-- FIXME: construct the associated scope
|
||||||
@ -188,28 +188,28 @@ typecheckingAnalysis = Analysis{..}
|
|||||||
_ ... m = pure (Just m)
|
_ ... m = pure (Just m)
|
||||||
|
|
||||||
|
|
||||||
data Constraint name = Type name :===: Type name
|
data Constraint = Type :===: Type
|
||||||
deriving (Eq, Ord, Show)
|
deriving (Eq, Ord, Show)
|
||||||
|
|
||||||
infix 4 :===:
|
infix 4 :===:
|
||||||
|
|
||||||
data Solution name
|
data Solution
|
||||||
= Int := Type name
|
= Int := Type
|
||||||
deriving (Eq, Ord, Show)
|
deriving (Eq, Ord, Show)
|
||||||
|
|
||||||
infix 5 :=
|
infix 5 :=
|
||||||
|
|
||||||
meta :: (Carrier sig m, Member Fresh sig) => m (Type name)
|
meta :: (Carrier sig m, Member Fresh sig) => m Type
|
||||||
meta = pure <$> Fresh.fresh
|
meta = pure <$> Fresh.fresh
|
||||||
|
|
||||||
unify :: (Carrier sig m, Member (State (Set.Set (Constraint name))) sig, Ord name) => Type name -> Type name -> m ()
|
unify :: (Carrier sig m, Member (State (Set.Set Constraint)) sig) => Type -> Type -> m ()
|
||||||
unify t1 t2
|
unify t1 t2
|
||||||
| t1 == t2 = pure ()
|
| t1 == t2 = pure ()
|
||||||
| otherwise = modify (<> Set.singleton (t1 :===: t2))
|
| otherwise = modify (<> Set.singleton (t1 :===: t2))
|
||||||
|
|
||||||
type Substitution name = IntMap.IntMap (Type name)
|
type Substitution = IntMap.IntMap Type
|
||||||
|
|
||||||
solve :: (Member (State (Substitution name)) sig, MonadFail m, Ord name, Show name, Carrier sig m) => Set.Set (Constraint name) -> m ()
|
solve :: (Member (State Substitution) sig, MonadFail m, Carrier sig m) => Set.Set Constraint -> m ()
|
||||||
solve cs = for_ cs solve
|
solve cs = for_ cs solve
|
||||||
where solve = \case
|
where solve = \case
|
||||||
-- FIXME: how do we enforce proper subtyping? row polymorphism or something?
|
-- FIXME: how do we enforce proper subtyping? row polymorphism or something?
|
||||||
|
Loading…
Reference in New Issue
Block a user