Fix bug in failing match in 'do'.

lib/Control/Monad/State/Strict.hs

@@ -5,6 +5,7 @@ module Control.Monad.State.Strict(
   ) where
 import Prelude
 import Control.Monad
+import Control.Monad.Fail
 
 data State s a = S (s -> (a, s))
 
@@ -27,6 +28,8 @@ instance forall s . Monad (State s) where
   (>>) = (*>)
   return = pure
 
+instance forall s . MonadFail (State s)
+
 runState :: forall s a . State s a -> (s -> (a,s))
 runState (S x) = x
 

lib/Numeric.hs

@@ -18,6 +18,7 @@ module Numeric(
 import Primitives
 import Control.Error
 import Control.Monad
+import Control.Monad.Fail
 import Data.Bool
 import Data.Char
 import Data.Eq
@@ -58,9 +59,7 @@ readSigned readPos = readParen False read'
     read' :: ReadS a
     read' r  = readPos r ++
                 do
-                  -- XXX compiler broken ('-',s) <- lex r
-                  (c,s) <- lex r
-                  guard (c == '-')
+                  ('-',s) <- lex r
                   (x, t) <- readPos s
                   return (- x, t)
 

lib/Text/Read.hs

@@ -12,6 +12,7 @@ module Text.Read(
 import Primitives
 import Control.Error
 import Control.Monad
+import Control.Monad.Fail
 import Data.Char
 import Data.Bool_Type
 import Data.Eq
@@ -44,13 +45,9 @@ readParen b g =
     optional r = g r ++ mandatory r
     mandatory :: ReadS a
     mandatory r = do
-      -- XXX compiler broken ('(',s) <- lex r
-      (lp,s) <- lex r
-      guard (lp == '(')
+      ('(',s) <- lex r
       (x,t) <- optional s
-      -- (')',u) <- lex t
-      (rp,u) <- lex t
-      guard (rp == ')')
+      (')',u) <- lex t
       return (x,u)
 
 -- Really bad lexer

src/MicroHs/TypeCheck.hs

@@ -1116,7 +1116,10 @@ expandClass dcls@(Class ctx (iCls, vks) fds ms) = do
 expandClass d = return [d]
 
 simpleEqn :: Expr -> [Eqn]
-simpleEqn e = [Eqn [] $ EAlts [([], e)] []]
+simpleEqn e = [Eqn [] $ simpleAlts e]
+
+simpleAlts :: Expr -> EAlts
+simpleAlts e = EAlts [([], e)] []
 
 -- Keep the list empty if there are no fundeps
 mkIFunDeps :: [Ident] -> [FunDep] -> [IFunDep]
@@ -1486,8 +1489,13 @@ tcExprR mt ae =
                 ibind = mkIdentSLoc loc ">>="
                 sbind = maybe ibind (\ mn -> qualIdent mn ibind) mmn
                 x = eVarI loc "$b"
+                patAlt = [(p, simpleAlts $ EDo mmn ss)]
+                failMsg s = EApp (EVar (mkIdentSLoc loc "fail")) (ELit loc (LStr s))
+                failAlt =
+                  if failureFree p then []
+                  else [(EVar dummyIdent, simpleAlts $ failMsg "bind")]
               tcExpr mt (EApp (EApp (EVar sbind) a)
-                              (eLam [x] (ECase x [(p, EAlts [([], EDo mmn ss)] [])])))
+                              (eLam [x] (ECase x (patAlt ++ failAlt))))
             SThen a -> do
               let
                 ithen = mkIdentSLoc loc ">>"
@@ -1572,6 +1580,13 @@ tcExprR mt ae =
     _ -> error $ "tcExpr: cannot handle: " ++ show (getSLoc ae) ++ " " ++ show ae
       -- impossible
 
+-- Approximation if failure free
+failureFree :: EPat -> Bool
+failureFree (EVar _) = True
+failureFree (ETuple ps) = all failureFree ps
+failureFree (ESign p _) = failureFree p
+failureFree _ = False
+
 eSetFields :: EField -> Expr -> Expr
 --eSetFields ([i], e) r = eSetField (i, e) r
 eSetFields (EField is e) r =

tests/Makefile

@@ -57,6 +57,7 @@ test:
 	$(TMHS) Record     && $(EVAL) > Record.out     && diff Record.ref Record.out
 	$(TMHS) Deriving   && $(EVAL) > Deriving.out   && diff Deriving.ref Deriving.out
 	$(TMHS) Unicode    && $(EVAL) > Unicode.out    && diff Unicode.ref Unicode.out
+	$(TMHS) BindPat    && $(EVAL) > BindPat.out    && diff BindPat.ref BindPat.out
 
 errtest:
 	sh errtester.sh < errmsg.test