Merge pull request #81 from konsumlamm/EmptyCase

Fix empty lambda case

Makefile

@@ -137,11 +137,11 @@ runtest:	bin/mhseval bin/gmhs tests/*.hs
 	cd tests; make alltest
 
 # Run test examples with mhs-compiled compiler
-runtestmhs: bin/mhs
+runtestmhs: bin/mhseval bin/mhs
 	cd tests; make MHS=../bin/mhs cache; make MHS="../bin/mhs +RTS -H4M -RTS -CR" info test errtest
 
 # Run test examples going via JavaScript
-runtestemscripten: bin/mhs
+runtestemscripten: bin/mhseval bin/mhs
 	cd tests; make MHS=../bin/mhs cache; MHSDIR=.. make MHS="../bin/mhs -CR -temscripten -oout.js" EVAL="node out.js" info test errtest
 
 

README.md

@@ -51,6 +51,7 @@ Differences:
    * DefaultSignatures
    * DoAndIfThenElse
    * DuplicateRecordFields
+   * EmptyCase
    * EmptyDataDecls
    * ExistentialQuantification
    * ExplicitNamespaces

src/MicroHs/Desugar.hs

@@ -117,7 +117,7 @@ dsEqns loc eqns =
           in  (ps', dsAlts alts)
         ex = dsCaseExp loc (vs ++ xs) (map Var xs) (map mkArm eqns)
       in foldr Lam ex xs
-    _ -> impossible
+    _ -> eMatchErr loc
 
 dsAlts :: EAlts -> (Exp -> Exp)
 dsAlts (EAlts alts bs) = dsBinds bs . dsAltsL alts
@@ -219,7 +219,7 @@ dsExpr aexpr =
     EApp (EApp (EVar app) (EListish (LCompr e stmts))) l | app == mkIdent "Data.List_Type.++" ->
       dsExpr $ dsCompr e stmts l
     EApp f a -> App (dsExpr f) (dsExpr a)
-    ELam qs -> dsEqns (getSLoc aexpr) qs
+    ELam l qs -> dsEqns l qs
     ELit l (LExn s) -> Var (mkIdentSLoc l s)
     ELit _ (LChar c) -> Lit (LInt (ord c))
     ELit _ (LInteger i) -> encodeInteger i

src/MicroHs/Expr.hs

@@ -6,7 +6,7 @@ module MicroHs.Expr(
   ImportItem(..),
   ImpType(..),
   EDef(..), showEDefs,
-  Expr(..), eLam, eEqn, eEqns, showExpr, eqExpr,
+  Expr(..), eLam, eLamWithSLoc, eEqn, eEqns, showExpr, eqExpr,
   Listish(..),
   Lit(..), showLit,
   CType(..),
@@ -107,7 +107,7 @@ data Expr
   = EVar Ident
   | EApp Expr Expr
   | EOper Expr [(Ident, Expr)]
-  | ELam [Eqn]
+  | ELam SLoc [Eqn]
   | ELit SLoc Lit
   | ECase Expr [ECaseArm]
   | ELet [EBind] Expr
@@ -150,7 +150,10 @@ unEField _ = impossible
 type FunDep = ([Ident], [Ident])
 
 eLam :: [EPat] -> Expr -> Expr
-eLam ps e = ELam $ eEqns ps e
+eLam = eLamWithSLoc noSLoc
+
+eLamWithSLoc :: SLoc -> [EPat] -> Expr -> Expr
+eLamWithSLoc loc ps e = ELam loc $ eEqns ps e
 
 eEqns :: [EPat] -> Expr -> [Eqn]
 eEqns ps e = [eEqn ps e]
@@ -361,7 +364,7 @@ instance HasLoc Expr where
   getSLoc (EVar i) = getSLoc i
   getSLoc (EApp e _) = getSLoc e
   getSLoc (EOper e _) = getSLoc e
-  getSLoc (ELam qs) = getSLoc qs
+  getSLoc (ELam l _) = l
   getSLoc (ELit l _) = l
   getSLoc (ECase e _) = getSLoc e
   getSLoc (ELet bs _) = getSLoc bs
@@ -519,7 +522,7 @@ allVarsExpr' aexpr =
     EVar i -> (i:)
     EApp e1 e2 -> allVarsExpr' e1 . allVarsExpr' e2
     EOper e1 ies -> allVarsExpr' e1 . composeMap (\ (i,e2) -> (i :) . allVarsExpr' e2) ies
-    ELam qs -> composeMap allVarsEqn qs
+    ELam _ qs -> composeMap allVarsEqn qs
     ELit _ _ -> id
     ECase e as -> allVarsExpr' e . composeMap allVarsCaseArm as
     ELet bs e -> composeMap allVarsBind' bs . allVarsExpr' e
@@ -727,7 +730,7 @@ ppExprR raw = ppE
                        cop = head op
         EApp _ _ -> ppApp [] ae
         EOper e ies -> ppE (foldl (\ e1 (i, e2) -> EApp (EApp (EVar i) e1) e2) e ies)
-        ELam qs -> parens $ text "\\" <> ppEqns empty (text "->") qs
+        ELam _ qs -> parens $ text "\\" <> ppEqns empty (text "->") qs
         ELit _ i -> text (showLit i)
         ECase e as -> text "case" <+> ppE e <+> text "of" $$ nest 2 (vcat (map ppCaseArm as))
         ELet bs e -> text "let" $$ nest 2 (vcat (map ppEBind bs)) $$ text "in" <+> ppE e

src/MicroHs/Parse.hs

@@ -658,14 +658,15 @@ pExprApp = do
   pure $ foldl EApp f as
 
 pLam :: P Expr
-pLam =
-    pSpec '\\' *>
-      (    eLam <$> esome pAPat <*> (pSRArrow *> pExpr)
-       <|< eLamCase <$> (pKeyword "case" *> pBlock pCaseArm)
-      )
+pLam = do
+  loc <- getSLoc
+  pSpec '\\' *>
+    (    eLamWithSLoc loc <$> esome pAPat <*> (pSRArrow *> pExpr)
+     <|< eLamCase loc <$> (pKeyword "case" *> pBlock pCaseArm)
+    )
 
-eLamCase :: [ECaseArm] -> Expr
-eLamCase as = ELam [ Eqn [p] a | (p, a) <- as ]
+eLamCase :: SLoc -> [ECaseArm] -> Expr
+eLamCase loc as = ELam loc [ Eqn [p] a | (p, a) <- as ]
 
 pCase :: P Expr
 pCase = ECase <$> (pKeyword "case" *> pExpr) <*> (pKeyword "of" *> pBlock pCaseArm)

src/MicroHs/TypeCheck.hs

@@ -1247,8 +1247,8 @@ expandInst dinst@(Instance act bs) = do
   -- XXX this ignores type signatures and other bindings
   -- XXX should tack on signatures with ESign
   let clsMdl = qualOf qiCls                   -- get class's module name
-      ies = [(i, ELam qs) | BFcn i qs <- bs]
-      meth i = fromMaybe (ELam $ simpleEqn $ EVar $ setSLocIdent loc $ mkDefaultMethodId $ qualIdent clsMdl i) $ lookup i ies
+      ies = [(i, ELam noSLoc qs) | BFcn i qs <- bs]
+      meth i = fromMaybe (ELam noSLoc $ simpleEqn $ EVar $ setSLocIdent loc $ mkDefaultMethodId $ qualIdent clsMdl i) $ lookup i ies
       meths = map meth mis
       sups = map (const (EVar $ mkIdentSLoc loc dictPrefixDollar)) supers
       args = sups ++ meths
@@ -1656,7 +1656,7 @@ tcExprR mt ae =
             _ -> return $ substEUVar [(ugly, res)] etmp'
 
     EOper e ies -> tcOper e ies >>= tcExpr mt
-    ELam qs -> tcExprLam mt qs
+    ELam _ qs -> tcExprLam mt loc qs
     ELit _ lit -> do
       tcm <- gets tcMode
       case tcm of
@@ -2033,10 +2033,10 @@ dictPrefixDollar = dictPrefix ++ uniqIdentSep
 newDictIdent :: SLoc -> T Ident
 newDictIdent loc = newIdent loc dictPrefix
 
-tcExprLam :: Expected -> [Eqn] -> T Expr
-tcExprLam mt qs = do
+tcExprLam :: Expected -> SLoc -> [Eqn] -> T Expr
+tcExprLam mt loc qs = do
   t <- tGetExpType mt
-  ELam <$> tcEqns False t qs
+  ELam loc <$> tcEqns False t qs
 
 tcEqns :: Bool -> EType -> [Eqn] -> T [Eqn]
 --tcEqns _ t eqns | trace ("tcEqns: " ++ showEBind (BFcn dummyIdent eqns) ++ " :: " ++ show t) False = undefined
@@ -2262,7 +2262,7 @@ tcPat mt ae =
         Nothing -> impossible
 
     EOr ps -> do
-      let orFun = ELam $ [ eEqn [p] true | p <- ps] ++ [ eEqn [eDummy] (eFalse loc) ]
+      let orFun = ELam noSLoc $ [ eEqn [p] true | p <- ps] ++ [ eEqn [eDummy] (eFalse loc) ]
           true = eTrue loc
       tcPat mt $ EViewPat orFun true
 

tests/EmptyCase.hs

@@ -0,0 +1,12 @@
+module EmptyCase where
+
+data Void
+
+absurd1 :: Void -> a
+absurd1 x = case x of {}
+
+absurd2 :: Void -> a
+absurd2 = \case {}
+
+main :: IO ()
+main = pure ()

tests/Makefile

@@ -81,6 +81,7 @@ test:
 	$(TMHS) PatSyn     && $(EVAL) > PatSyn.out     && diff PatSyn.ref PatSyn.out
 	$(TMHS) Coerce     && $(EVAL) > Coerce.out     && diff Coerce.ref Coerce.out
 	$(TMHS) PatBind    && $(EVAL) > PatBind.out    && diff PatBind.ref PatBind.out
+	$(TMHS) EmptyCase  && $(EVAL) > EmptyCase.out
 
 errtest:
 	sh errtester.sh $(MHS) < errmsg.test