handle application as list
This commit is contained in:
parent
6499987dd8
commit
413f7d3a21
|
@ -30,10 +30,11 @@ runProcess = (fst <$>) .: runStateT
|
||||||
postprocess :: [H.Def] -> Process [TL]
|
postprocess :: [H.Def] -> Process [TL]
|
||||||
postprocess defs = addDef <~> defs >> defToTL <~> defs
|
postprocess defs = addDef <~> defs >> defToTL <~> defs
|
||||||
|
|
||||||
|
-- just adds types for processing type signatures
|
||||||
addDef :: H.Def -> Process ()
|
addDef :: H.Def -> Process ()
|
||||||
addDef = \case
|
addDef = \case
|
||||||
H.VarDef _ i t _ -> lift . addEnv i =<< typeSigToPolyT t -- the type checker will check this matches the exp
|
|
||||||
H.TypeDef _ t _ -> insertType =<< fst <$> typeSigToIdParams t
|
H.TypeDef _ t _ -> insertType =<< fst <$> typeSigToIdParams t
|
||||||
|
H.VarDef _ i t _ -> pure ()
|
||||||
|
|
||||||
-- add type before typesig to id params
|
-- add type before typesig to id params
|
||||||
defToTL :: H.Def -> Process TL
|
defToTL :: H.Def -> Process TL
|
||||||
|
@ -92,12 +93,7 @@ expToExp :: H.Exp -> Process Exp
|
||||||
expToExp = \case
|
expToExp = \case
|
||||||
H.ExpLet p as e -> Let p <$> assignTo2pl <~> as <*> expToExp e
|
H.ExpLet p as e -> Let p <$> assignTo2pl <~> as <*> expToExp e
|
||||||
H.ExpAbs p is e -> Abs p is <$> expToExp e
|
H.ExpAbs p is e -> Abs p is <$> expToExp e
|
||||||
H.ExpApp p e1 (e2:es) -> do
|
H.ExpApp p e es -> App p <$> expToExp e <*> expToExp <~> es
|
||||||
e1' <- expToExp e1
|
|
||||||
e2' <- expToExp e2
|
|
||||||
es' <- traverse expToExp es
|
|
||||||
pure (foldl (App p) (App p e1' e2') es')
|
|
||||||
H.ExpApp p e [] -> throwError Oop
|
|
||||||
H.ExpVar p i -> pure (Var p i)
|
H.ExpVar p i -> pure (Var p i)
|
||||||
|
|
||||||
declTo2pl :: H.Decl -> Process (Id, MonoT)
|
declTo2pl :: H.Decl -> Process (Id, MonoT)
|
||||||
|
|
35
src/TC.hs
35
src/TC.hs
|
@ -149,6 +149,9 @@ constructs _ _ = False
|
||||||
|
|
||||||
infer :: Exp -> Check (Subst, MonoT)
|
infer :: Exp -> Check (Subst, MonoT)
|
||||||
infer = setPos >=> \case
|
infer = setPos >=> \case
|
||||||
|
|
||||||
|
Var _ i -> (emptySubst,) <$> lookupType i
|
||||||
|
|
||||||
Let _ [] e -> infer e
|
Let _ [] e -> infer e
|
||||||
Let p ((i,e1):ies) e2 -> do
|
Let p ((i,e1):ies) e2 -> do
|
||||||
(s1, t1) <- infer e1
|
(s1, t1) <- infer e1
|
||||||
|
@ -165,13 +168,31 @@ infer = setPos >=> \case
|
||||||
(s, t) <- infer (Abs p is e)
|
(s, t) <- infer (Abs p is e)
|
||||||
pure (s, apply s tv `TArr` t)
|
pure (s, apply s tv `TArr` t)
|
||||||
|
|
||||||
App p e1 e2 -> localEnv' $ do
|
App _ e es -> go e (reverse es)
|
||||||
tv <- fresh
|
where
|
||||||
|
go :: Exp -> [Exp] -> Check (Subst, MonoT)
|
||||||
|
go _ [] = throwError Oop
|
||||||
|
go e1 [e2] = localEnv' $ do
|
||||||
|
|
||||||
(s1, t1) <- infer e1
|
(s1, t1) <- infer e1
|
||||||
applyEnv s1
|
applyEnv s1
|
||||||
(s2, t2) <- infer e2
|
|
||||||
s3 <- unify (apply s2 t1) (TArr t2 tv)
|
|
||||||
return (s3 <&> s2 <&> s1, apply s3 tv)
|
|
||||||
App _ _ _ -> throwError Oop
|
|
||||||
|
|
||||||
Var _ i -> (emptySubst,) <$> lookupType i
|
(s2, t2) <- infer e2
|
||||||
|
|
||||||
|
tv <- fresh
|
||||||
|
|
||||||
|
s3 <- unify (apply s2 t1) (t2 `TArr` tv)
|
||||||
|
pure (s3 <&> s2 <&> s1, apply s3 tv)
|
||||||
|
|
||||||
|
go e1 (e2:es) = localEnv' $ do
|
||||||
|
|
||||||
|
(s1, t1) <- go e1 es
|
||||||
|
applyEnv s1
|
||||||
|
|
||||||
|
(s2, t2) <- infer e2
|
||||||
|
|
||||||
|
tv <- fresh
|
||||||
|
|
||||||
|
s3 <- unify (apply s2 t1) (t2 `TArr` tv)
|
||||||
|
|
||||||
|
pure (s3 <&> s2 <&> s1, apply s3 tv)
|
||||||
|
|
|
@ -41,7 +41,7 @@ type Exp = Exp' Pos
|
||||||
data Exp' a
|
data Exp' a
|
||||||
= Let a [(Id,Exp)] Exp
|
= Let a [(Id,Exp)] Exp
|
||||||
| Abs a [Id] Exp
|
| Abs a [Id] Exp
|
||||||
| App a Exp Exp
|
| App a Exp [Exp]
|
||||||
| Var a Id
|
| Var a Id
|
||||||
deriving Show
|
deriving Show
|
||||||
|
|
||||||
|
|
Loading…
Reference in New Issue
Block a user