ref: c166cdc6d57d869aec823386c1cd54fc4e46691e
parent: 60b8dd2f6386493d4ca75ae48e5cd662429eb58a
author: Lennart Augustsson <lennart.augustsson@epicgames.com>
date: Tue Sep 19 09:32:15 EDT 2023
Implement local type signatures.
--- a/comb/mhs.comb
+++ b/comb/mhs.comb
@@ -1,3 +1,3 @@
v3.4
-828
-(($A :0 ((_625 _576) (($B ((($S' ($C ((($C' ($S' _625)) (($B ($C _2)) _560)) (($B ($B (_625 _654))) ((($C' ($C' $C)) ((($C' ($S' ($C' $C))) ((($C' ($C' ($C' $C))) ((($C' ($C' ($C' ($C' $S')))) (($B ($B ($B ($B $C)))) ((($C' ($C' ($C' $B))) (($B ($B ($B ($C' $S)))) ((($C' ($C' ($C' ($C' $C)))) ((($C' ($C' ($C' ($C' ($C' $S'))))) (($B ($B ($B ($B ($B $C))))) ((($C' ($C' ($C' ($C' ($C' $C))))) ((($C' ($C' ($C' $B))) (($B ($B ($B ($C' ($C' $S'))))) ((($C' ($C' ($C' ($C' ($C' $C'))))) ((($C' ($C' ($C' ($S' ($C' $C'))))) (($B ($B ($B ($B $B')))) ((($S' $B) ($B' ($B' (($B ($S' $B)) (($B ($B _626)) ((($C' $B) (($B _722) (($B _644) ((($C' _759) _8) 0)))) (($B (_722 _647)) (($B (_660 "top level defns: ")) _606)))))))) ((($S' $B) ($B' (($B ($C' $B)) (($B $B') (($B ($B _626)) ((($C' $B) (($B _722) (($B _644) ((($C' _759) _8) 1)))) (_643 ($T (($B ($B (_722 _647))) ((($C' $B) (($B _660) ((($C' _660) _566) " = "))) _392)))))))))) ((($C' $B) ((($S' $C') (($B $C') (($B $C') _9))) ((($S' $B) (($B ($C' ($C' _626))) ((($C' $B) ($B' (($B _722) (($B _649) _11)))) (($B _660) ((($C' _660) (($B (_660 _1)) _606)) (($O 10) $K)))))) (($B ($B (_625 _654))) ((($C' $B) ($B' (($B _722) (($B _644) ((($C' _759) _8) 0))))) (($B ($B (_722 _647))) ((($C' ($C' _660)) (($B ($B (_660 "final pass "))) (($B ($B (_620 6))) (($B ($B _606)) _753)))) "ms"))))))) _3))))) (($B (($C' $C) (($B ($C _665)) _392))) (($C _678) (_694 0))))) (($B ($C $B)) (($B ($B ($C $B))) (($B ($B $BK)) ((($C' ($C' ($C' ($C' _660)))) (($B ($C' ($C' _660))) ((($C' ($C' ($C' _660))) (($B (($C' $B) (($B _660) ((($C' _660) (($B (_660 "(($A :")) _606)) (($O 32) $K))))) ($B _392))) ") "))) (($O 41) $K)))))))) $T)) (($B $Y) ((($C' ($C' $S)) ((($C' ($C' $S)) ((($C' $B) $P) ((($S' ($C' $B)) ($B _368)) $I))) ($BK $K))) $K))))) (($B (($S' _722) (($B _719) (($B (_722 _766)) (($B (_660 "main: findIdent: ")) _566))))) (($C' _595) _563)))) _602))) (($B ($B _599)) ((($C' $B) (($B _662) (($B $T) (($B ($C $B)) (($B ($B $BK)) ((($C' ($C' ($C' $O))) ($B (($C' $P) _563))) $K)))))) (($C _678) (_694 0))))))) ($T $A))) ($T $K))) $I)) (($B (_722 _367)) (($B (_722 _560)) (($B (_660 (($O 95) $K))) _606)))))))) (($S (($S ((($S' _7) (($B _677) (_664 (_618 "-v")))) ((_693 _618) "-r"))) (($B (_658 (($O 46) $K))) (($B _721) (_663 ((_682 _744) "-i")))))) (($B (_722 _689)) ((($C' _660) (($B _721) (_663 ((_682 _744) "-o")))) (($O "out.comb") $K))))) (($B (($S (($C ((($C' _755) _677) 1)) (_766 "Usage: mhs [-v] [-r] [-iPATH] [-oFILE] ModuleName"))) _689)) (_664 ((_723 _764) ((_723 (_618 (($O 45) $K))) (_675 1))))))) (_685 ((_723 _764) (_618 "--")))))) (($A :1 "v3.4\10&") (($A :2 ((($S' ($S' _625)) _16) (($B ($B ($B (_625 _654)))) ((($C' ($C' $B)) (($B ($B ($C' (($S' _626) (($B (_722 _645)) (($B (_722 (_676 1000000))) _192)))))) (($B ($B ($B ($B (_625 _654))))) ((($C' $B) (($B ($C' $B)) (($B ($B ($C' _626))) ((($C' $B) ($B' (($B _722) (($B _644) ((($C' _759) _8) 0))))) (($B ($B (_722 _647))) ((($C' ($C' _660)) (($B ($B (_660 "combinator conversion "))) (($B ($B (_620 6))) (($B ($B _606)) _753)))) "ms")))))) (($B ($B _627)) (($B $P) (($C _569) (_560 "main")))))))) (_662 ($T ((($C' ($C' $O)) ((($C' $B) $P) _395)) $K))))))) (($A :3 ($T (($C ((($C' $C') (($B ($S' ($B (_625 _576)))) (($B ($B ($B (($C' _577) ((($C' _748) (($B _677) (_685 ((_723 _764) (_618 "--"))))) 1))))) (($B ($B ($B (_722 _6)))) ($C $C))))) (($B ($B $Y)) (($B ($B ($B _551))) (($C' ($C' _662)) (($B ($B $T)) ((($C' ($C' ($C' ($C' $O)))) (($B ($B (($C' $B) $P))) ($B _4))) $K))))))) (($B (($S' _722) (($B _719) (($B (_722 _766)) (($B (_660 "not found ")) _566))))) ($C _552))))) (($A :4 ((($C' $C) ((($S' $C) ((($C' ($C' $S')) (($S $P) ((($S' ($C' $B)) (($B ($B _6)) _4)) _4))) ($BK $K))) ((($C' ($S' $C)) ((($C' ($C' $C)) (($B (($C' $C) (($B ($P _6)) $K))) ((($C' $B) _4) _394))) (($B (_722 (_719 (_766 "primlookup")))) (($C (_699 _618)) _5)))) $K))) (_766 "trans: impossible"))) (($A :5 (($O (($P (($O 66) $K)) $B)) (($O (($P (($O 79) $K)) $O)) (($O (($P (($O 75) $K)) $K)) (($O (($P "C'") $C')) (($O (($P (($O 67) $K)) $C)) (($O (($P (($O 65) $K)) $A)) (($O (($P "
\ No newline at end of file
+830
+(($A :0 ((_627 _578) (($B ((($S' ($C ((($C' ($S' _627)) (($B ($C _2)) _562)) (($B ($B (_627 _656))) ((($C' ($C' $C)) ((($C' ($S' ($C' $C))) ((($C' ($C' ($C' $C))) ((($C' ($C' ($C' ($C' $S')))) (($B ($B ($B ($B $C)))) ((($C' ($C' ($C' $B))) (($B ($B ($B ($C' $S)))) ((($C' ($C' ($C' ($C' $C)))) ((($C' ($C' ($C' ($C' ($C' $S'))))) (($B ($B ($B ($B ($B $C))))) ((($C' ($C' ($C' ($C' ($C' $C))))) ((($C' ($C' ($C' $B))) (($B ($B ($B ($C' ($C' $S'))))) ((($C' ($C' ($C' ($C' ($C' $C'))))) ((($C' ($C' ($C' ($S' ($C' $C'))))) (($B ($B ($B ($B $B')))) ((($S' $B) ($B' ($B' (($B ($S' $B)) (($B ($B _628)) ((($C' $B) (($B _724) (($B _646) ((($C' _761) _8) 0)))) (($B (_724 _649)) (($B (_662 "top level defns: ")) _608)))))))) ((($S' $B) ($B' (($B ($C' $B)) (($B $B') (($B ($B _628)) ((($C' $B) (($B _724) (($B _646) ((($C' _761) _8) 1)))) (_645 ($T (($B ($B (_724 _649))) ((($C' $B) (($B _662) ((($C' _662) _568) " = "))) _393)))))))))) ((($C' $B) ((($S' $C') (($B $C') (($B $C') _9))) ((($S' $B) (($B ($C' ($C' _628))) ((($C' $B) ($B' (($B _724) (($B _651) _11)))) (($B _662) ((($C' _662) (($B (_662 _1)) _608)) (($O 10) $K)))))) (($B ($B (_627 _656))) ((($C' $B) ($B' (($B _724) (($B _646) ((($C' _761) _8) 0))))) (($B ($B (_724 _649))) ((($C' ($C' _662)) (($B ($B (_662 "final pass "))) (($B ($B (_622 6))) (($B ($B _608)) _755)))) "ms"))))))) _3))))) (($B (($C' $C) (($B ($C _667)) _393))) (($C _680) (_696 0))))) (($B ($C $B)) (($B ($B ($C $B))) (($B ($B $BK)) ((($C' ($C' ($C' ($C' _662)))) (($B ($C' ($C' _662))) ((($C' ($C' ($C' _662))) (($B (($C' $B) (($B _662) ((($C' _662) (($B (_662 "(($A :")) _608)) (($O 32) $K))))) ($B _393))) ") "))) (($O 41) $K)))))))) $T)) (($B $Y) ((($C' ($C' $S)) ((($C' ($C' $S)) ((($C' $B) $P) ((($S' ($C' $B)) ($B _369)) $I))) ($BK $K))) $K))))) (($B (($S' _724) (($B _721) (($B (_724 _768)) (($B (_662 "main: findIdent: ")) _568))))) (($C' _597) _565)))) _604))) (($B ($B _601)) ((($C' $B) (($B _664) (($B $T) (($B ($C $B)) (($B ($B $BK)) ((($C' ($C' ($C' $O))) ($B (($C' $P) _565))) $K)))))) (($C _680) (_696 0))))))) ($T $A))) ($T $K))) $I)) (($B (_724 _368)) (($B (_724 _562)) (($B (_662 (($O 95) $K))) _608)))))))) (($S (($S ((($S' _7) (($B _679) (_666 (_620 "-v")))) ((_695 _620) "-r"))) (($B (_660 (($O 46) $K))) (($B _723) (_665 ((_684 _746) "-i")))))) (($B (_724 _691)) ((($C' _662) (($B _723) (_665 ((_684 _746) "-o")))) (($O "out.comb") $K))))) (($B (($S (($C ((($C' _757) _679) 1)) (_768 "Usage: mhs [-v] [-r] [-iPATH] [-oFILE] ModuleName"))) _691)) (_666 ((_725 _766) ((_725 (_620 (($O 45) $K))) (_677 1))))))) (_687 ((_725 _766) (_620 "--")))))) (($A :1 "v3.4\10&") (($A :2 ((($S' ($S' _627)) _16) (($B ($B ($B (_627 _656)))) ((($C' ($C' $B)) (($B ($B ($C' (($S' _628) (($B (_724 _647)) (($B (_724 (_678 1000000))) _192)))))) (($B ($B ($B ($B (_627 _656))))) ((($C' $B) (($B ($C' $B)) (($B ($B ($C' _628))) ((($C' $B) ($B' (($B _724) (($B _646) ((($C' _761) _8) 0))))) (($B ($B (_724 _649))) ((($C' ($C' _662)) (($B ($B (_662 "combinator conversion "))) (($B ($B (_622 6))) (($B ($B _608)) _755)))) "ms")))))) (($B ($B _629)) (($B $P) (($C _571) (_562 "main")))))))) (_664 ($T ((($C' ($C' $O)) ((($C' $B) $P) _396)) $K))))))) (($A :3 ($T (($C ((($C' $C') (($B ($S' ($B (_627 _578)))) (($B ($B ($B (($C' _579) ((($C' _750) (($B _679) (_687 ((_725 _766) (_620 "--"))))) 1))))) (($B ($B ($B (_724 _6)))) ($C $C))))) (($B ($B $Y)) (($B ($B ($B _553))) (($C' ($C' _664)) (($B ($B $T)) ((($C' ($C' ($C' ($C' $O)))) (($B ($B (($C' $B) $P))) ($B _4))) $K))))))) (($B (($S' _724) (($B _721) (($B (_724 _768)) (($B (_662 "not found ")) _568))))) ($C _554))))) (($A :4 ((($C' $C) ((($S' $C) ((($C' ($C' $S')) (($S $P) ((($S' ($C' $B)) (($B ($B _6)) _4)) _4))) ($BK $K))) ((($C' ($S' $C)) ((($C' ($C' $C)) (($B (($C' $C) (($B ($P _6)) $K))) ((($C' $B) _4) _395))) (($B (_724 (_721 (_768 "primlookup")))) (($C (_701 _620)) _5)))) $K))) (_768 "trans: impossible"))) (($A :5 (($O (($P (($O 66) $K)) $B)) (($O (($P (($O 79) $K)) $O)) (($O (($P (($O 75) $K)) $K)) (($O (($P "C'") $C')) (($O (($P (($O 67) $K)) $C)) (($O (($P (($O 65) $K)) $A)) (($O (($P "
\ No newline at end of file
--- a/src/MicroHs/Desugar.hs
+++ b/src/MicroHs/Desugar.hs
@@ -61,6 +61,7 @@
de = (v, dsExpr e)
ds = [ (i, dsExpr (ECase (EVar v) [(p, oneAlt $ EVar i)])) | i <- patVars p ]
in de : ds
+ BSign _ _ -> []
dsEqns :: [Eqn] -> Exp
dsEqns eqns =
--- a/src/MicroHs/Expr.hs
+++ b/src/MicroHs/Expr.hs
@@ -140,7 +140,7 @@
data EStmt = SBind EPat Expr | SThen Expr | SLet [EBind]
--Xderiving (Show, Eq)
-data EBind = BFcn Ident [Eqn] | BPat EPat Expr
+data EBind = BFcn Ident [Eqn] | BPat EPat Expr | BSign Ident ETypeScheme
--Xderiving (Show, Eq)
-- A single equation for a function
@@ -231,6 +231,7 @@
case abind of
BFcn i eqns -> i : concatMap allVarsEqn eqns
BPat p e -> allVarsPat p ++ allVarsExpr e
+ BSign i _ -> [i]
allVarsEqn :: Eqn -> [Ident]
allVarsEqn eqn =
@@ -425,6 +426,7 @@
case ab of
BFcn i eqns -> showEDef (Fcn i eqns)
BPat p e -> showEPat p ++ " = " ++ showExpr e
+ BSign i t -> showIdent i ++ " :: " ++ showETypeScheme t
showCaseArm :: ECaseArm -> String
showCaseArm arm =
--- a/src/MicroHs/Parse.hs
+++ b/src/MicroHs/Parse.hs
@@ -468,7 +468,8 @@
pBind :: P EBind
pBind =
uncurry BFcn <$> pEqns
- <|< BPat <$> (pPatNotVar <* pSymbol "=") <*> pExpr
+ <|< BPat <$> (pPatNotVar <* pSymbol "=") <*> pExpr
+ <|< BSign <$> (pLIdentSym <* pSymbol "::") <*> pTypeScheme
-------------
--- a/src/MicroHs/TypeCheck.hs
+++ b/src/MicroHs/TypeCheck.hs
@@ -527,8 +527,9 @@
putValueTable venv
T.return a
-withExtTyps :: forall a . [(Ident, ETypeScheme)] -> T a -> T a
-withExtTyps env ta = T.do
+withExtTyps :: forall a . [IdKind] -> T a -> T a
+withExtTyps iks ta = T.do
+ let env = map (\ (IdKind v k) -> (v, ETypeScheme [] k)) iks
venv <- gets typeTable
extTyps env
a <- ta
@@ -676,12 +677,8 @@
-- traceM $ "tcDefValue: " ++ showLHS (i, vs) ++ " = " ++ showExpr rhs
(_, ETypeScheme iks tfn) <- tLookup "no type signature" i
mn <- gets moduleName
- let vks = map (\ (IdKind v k) -> (v, ETypeScheme [] k)) iks
- teqns <- withExtTyps vks $ tcEqns tfn eqns
- --tcExpr (Just t) $ ELam (map EVar vs) rhs
+ teqns <- withExtTyps iks $ tcEqns tfn eqns
T.return $ Fcn (qualIdent mn i) teqns
--- (et, _) <- withExtTyps vks (tcExpr (Just t) (foldr eLam1 rhs vs))
--- T.return (Fcn (qualIdent mn i, vs) (dropLam (length vs) et))
ForImp ie i t -> T.do
mn <- gets moduleName
T.return (ForImp ie (qualIdent mn i) t)
@@ -977,32 +974,42 @@
tcBinds :: forall a . [EBind] -> ([EBind] -> T a) -> T a
tcBinds xbs ta = T.do
let
+ tmap = M.fromList [ (i, t) | BSign i t <- xbs ]
xs = concatMap getBindVars xbs
- xts <- T.mapM (\ x -> T.fmap (pair x . ETypeScheme []) newUVar) xs
+ xts <- T.mapM (tcBindVarT tmap) xs
withExtVals xts $ T.do
nbs <- T.mapM tcBind xbs
ta nbs
+tcBindVarT :: M.Map ETypeScheme -> Ident -> T (Ident, ETypeScheme)
+tcBindVarT tmap x = T.do
+ case M.lookup x tmap of
+ Nothing -> T.do
+ t <- newUVar
+ T.return (x, ETypeScheme [] t)
+ Just t -> T.do
+ tt <- withTypeTable $ tcTypeScheme (Just kType) t
+ T.return (x, tt)
+
tcBind :: EBind -> T EBind
tcBind abind =
case abind of
BFcn i eqns -> T.do
- (_, t) <- tLookupInst "impossible!" i
- --(ELam _avs ea, _) <- tcExpr (Just t) $ ELam (map EVar vs) a
- teqns <- tcEqns t eqns
+ (_, ETypeScheme iks tfn) <- tLookup "impossible!" i
+ teqns <- withExtTyps iks $ tcEqns tfn eqns
T.return $ BFcn i teqns
--- (ea, _) <- tcExpr (Just t) $ foldr eLam1 a vs
--- T.return $ BFcn (i, vs) $ dropLam (length vs) ea
BPat p a -> T.do
(ep, tp) <- tcExpr Nothing p
(ea, _) <- tcExpr (Just tp) a
T.return $ BPat ep ea
+ BSign _ _ -> T.return abind
getBindVars :: EBind -> [Ident]
getBindVars abind =
case abind of
- BFcn i _ -> [i]
- BPat p _ -> patVars p
+ BFcn i _ -> [i]
+ BPat p _ -> patVars p
+ BSign _ _ -> []
-- Desugar [T] and (T,T,...)
dsType :: EType -> EType
--- /dev/null
+++ b/tests/LocalPoly.hs
@@ -1,0 +1,12 @@
+module LocalPoly(main) where
+import Prelude
+
+main :: IO ()
+main = do
+ putStrLn $ showPair (showPair showInt showString) (showPair showString showString) $ f 1 "a"
+
+f :: forall b . Int -> b -> ((Int, b), (b, b))
+f x b = (i x, i b)
+ where
+ i :: forall a . a -> (a, b)
+ i a = (a, b)
--- /dev/null
+++ b/tests/LocalPoly.ref
@@ -1,0 +1,1 @@
+((1,"a"),("a","a"))--- a/tests/Makefile
+++ b/tests/Makefile
@@ -17,6 +17,7 @@
$(MHS) Enum && $(EVAL) > Enum.out && diff Enum.ref Enum.out
$(MHS) Foreign && $(EVAL) > Foreign.out && diff Foreign.ref Foreign.out
$(MHS) MutRec && $(EVAL) > MutRec.out && diff MutRec.ref MutRec.out
+ $(MHS) LocalPoly && $(EVAL) > LocalPoly.out && diff LocalPoly.ref LocalPoly.out
time:
@echo Expect about 10s runtime
--
⑨