1
1
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:
Rob Rix 2019-11-05 11:45:59 -05:00
parent 814f6fe8cf
commit 18bc19a04e
No known key found for this signature in database
GPG Key ID: F188A01508EA1CF7

View File

@ -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?