shithub: MicroHs

Download patch

ref: 99e4b296308739934ffbc5e4951c39562f413ea4
parent: 4e1310bf340ce097b8a9e343df620a5a67230464
author: Lennart Augustsson <lennart.augustsson@epicgames.com>
date: Sat Nov 18 18:36:18 EST 2023 

Minor tweaks.


--- a/src/MicroHs/TypeCheck.hs
+++ b/src/MicroHs/TypeCheck.hs
@@ -1646,24 +1646,24 @@
 --tcEqn t _eqn | trace ("tcEqn: " ++ showEType t) False = undefined
 tcEqn t eqn =
   case eqn of
-    Eqn ps alts -> tcPats t ps $ \ tt ps' -> do
-      alts' <- tcAlts tt alts
+    Eqn ps alts -> tcPats t ps $ \ t' ps' -> do
+      alts' <- tcAlts t' alts
       return (Eqn ps' alts')
 
 -- Only used above
-tcPats :: forall a . EType -> [EPat] -> (EType -> [EPat] -> T a) -> T a
+tcPats :: EType -> [EPat] -> (EType -> [EPat] -> T Eqn) -> T Eqn
 tcPats t [] ta = ta t []
 tcPats t (p:ps) ta = do
   (tp, tr) <- unArrow (getSLoc p) t
   -- tCheckPatC dicts used in tcAlt solve
-  tCheckPatC tp p $ \ pp -> tcPats tr ps $ \ tt pps -> ta tt (pp : pps)
+  tCheckPatC tp p $ \ p' -> tcPats tr ps $ \ t' ps' -> ta t' (p' : ps')
 
 tcAlts :: EType -> EAlts -> T EAlts
-tcAlts tt (EAlts alts bs) =
+tcAlts t (EAlts alts bs) =
 --  trace ("tcAlts: bs in " ++ showEBinds bs) $
   tcBinds bs $ \ bs' -> do
 --    traceM ("tcAlts: bs out " ++ showEBinds bbs)
-    alts' <- mapM (tcAlt tt) alts
+    alts' <- mapM (tcAlt t) alts
     return (EAlts alts' bs')
 
 tcAlt :: EType -> EAlt -> T EAlt
@@ -1672,15 +1672,15 @@
   rhs' <- tCheckExprAndSolve t rhs
   return (ss', rhs')
 
-tcGuards :: forall a . [EStmt] -> ([EStmt] -> T a) -> T a
+tcGuards :: [EStmt] -> ([EStmt] -> T EAlt) -> T EAlt
 tcGuards [] ta = ta []
 tcGuards (s:ss) ta = tcGuard s $ \ rs -> tcGuards ss $ \ rss -> ta (rs:rss)
 
-tcGuard :: forall a . EStmt -> (EStmt -> T a) -> T a
+tcGuard :: EStmt -> (EStmt -> T EAlt) -> T EAlt
 tcGuard (SBind p e) ta = do
-  (ee, tt) <- tInferExpr e
+  (e', tt) <- tInferExpr e
   -- tCheckPatC dicts used in solving in tcAlt
-  tCheckPatC tt p $ \ p' -> ta (SBind p' ee)
+  tCheckPatC tt p $ \ p' -> ta (SBind p' e')
 tcGuard (SThen e) ta = do
   e' <- tCheckExprAndSolve (tBool (getSLoc e)) e
   ta (SThen e')
@@ -1903,8 +1903,9 @@
       teqns <- tcEqns False tt eqns
       return $ BFcn i teqns
     BPat p a -> do
-      ((sk, _, ep), tp) <- tInferPat p  -- pattern variables already bound
-      when (not (null sk)) $
+      ((sk, ds, ep), tp) <- tInferPat p  -- pattern variables already bound
+      -- This is just to complicated.
+      when (not (null sk) || not (null ds)) $
         tcError (getSLoc p) "existentials not allowed in pattern binding"
       ea <- tCheckExprAndSolve tp a
       return $ BPat ep ea
--- a/tests/errmsg.test
+++ b/tests/errmsg.test
@@ -141,4 +141,13 @@
 mhs: "../tmp/E.hs": line 4, col 12: kind error: cannot unify Type and (a2 -> a3)
 
 =====
+module E() where
+import Prelude
+data T = forall a . C a
+x :: Int
+x = let { C a = C (1::Int) } in a
+-----
+mhs: "../tmp/E.hs": line 6, col 11: existentials not allowed in pattern binding
+
+=====
 END
-- 
⑨