ref: c80754ecc3ce9155327e5cf739c23580042bf601
parent: dfa5b622f261ca873793928f9dd5a5d162bce3ae
author: Lennart Augustsson <lennart.augustsson@epicgames.com>
date: Wed Sep 20 06:08:21 EDT 2023
Better error message for runtime pattern match failure.
--- a/TODO
+++ b/TODO
@@ -1,7 +1,6 @@
* Add strict constructors
* Put on hackage
* Have compile return a Stats record of timing etc
-* Special noMatch function with location
* Add overloading
* Implement deriving
* Add forall to the syntax of types so it can be nested
--- a/comb/mhs.comb
+++ b/comb/mhs.comb
@@ -1,3 +1,3 @@
v3.4
-847
-(($A :0 ((_641 _591) (($B ((($S' ($C ((($C' ($S' _641)) (($B ($C _2)) _574)) (($B ($B (_641 _670))) ((($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 _642)) ((($C' $B) (($B _739) (($B _660) ((($C' _776) _9) 0)))) (($B (_739 _663)) (($B (_676 "top level defns: ")) _621)))))))) ((($S' $B) ($B' (($B ($C' $B)) (($B $B') (($B ($B _642)) ((($C' $B) (($B _739) (($B _660) ((($C' _776) _9) 1)))) (_659 ($T (($B ($B (_739 _663))) ((($C' $B) (($B _676) ((($C' _676) _580) " = "))) (($C _400) $K))))))))))) ((($C' $B) ((($S' $C') (($B $C') (($B $C') _10))) ((($S' $B) (($B ($C' ($C' _642))) ((($C' $B) ($B' (($B _739) (($B _665) _12)))) (($B _676) ((($C' _676) (($B (_676 _1)) _621)) (($O 10) $K)))))) (($B ($B (_641 _670))) ((($C' $B) ($B' (($B _739) (($B _660) ((($C' _776) _9) 0))))) (($B ($B (_739 _663))) ((($C' ($C' _676)) (($B ($B (_676 "final pass "))) (($B ($B (_635 6))) (($B ($B _621)) _770)))) "ms"))))))) _3))))) ((($C' ($C' $C)) (($B (($C' $C) (($B ($C _681)) _400))) (($C _694) (_710 0)))) $K))) (($B ($C $B)) (($B ($B ($C $B))) (($B ($B $BK)) (($B ($B (($C' $B) (($B _740) (($B _676) ((($C' _676) (($B (_676 "(($A :")) _621)) (($O 32) $K))))))) ((($C' $B) (($B ($C' _740)) ($B _400))) (($B (_740 (_676 ") "))) (($C _740) (_676 (($O 41) $K)))))))))))) $T)) (($B $Y) ((($C' ($C' $S)) ((($C' ($C' $S)) ((($C' $B) $P) ((($S' ($C' $B)) ($B _375)) $I))) ($BK $K))) $K))))) (($B (($S' _739) (($B _736) (($B (_739 _785)) (($B (_676 "main: findIdent: ")) _580))))) (($C' _610) _577)))) _617))) (($B ($B _614)) ((($C' $B) (($B _678) (($B $T) (($B ($C $B)) (($B ($B $BK)) ((($C' ($C' ($C' $O))) ($B (($C' $P) _577))) $K)))))) (($C _694) (_710 0))))))) ($T $A))) ($T $K))) $I)) (($B (_739 _374)) (($B (_739 _574)) (($B (_676 (($O 95) $K))) _621)))))))) (($S (($S ((($S' _8) (($B _693) (_680 (_633 "-v")))) ((_709 _633) "-r"))) (($B (_674 (($O 46) $K))) (($B _738) (_679 ((_698 _761) "-i")))))) (($B (_739 _705)) ((($C' _676) (($B _738) (_679 ((_698 _761) "-o")))) (($O "out.comb") $K))))) (($B (($S (($C ((($C' _772) _693) 1)) (_785 "Usage: mhs [-v] [-r] [-iPATH] [-oFILE] ModuleName"))) _705)) (_680 ((_740 _781) ((_740 (_633 (($O 45) $K))) (_691 1))))))) (_701 ((_740 _781) (_633 "--")))))) (($A :1 "v3.4\10&") (($A :2 ((($S' ($S' _641)) _17) (($B ($B ($B (_641 _670)))) ((($C' ($C' $B)) (($B ($B ($C' (($S' _641) (($B _643) (_732 _220)))))) (($B ($B ($B ($B $T)))) (($B ($B ($B ($B (_641 _670))))) ((($C' $B) (($B ($C' $B)) (($B ($B ($C' _642))) ((($C' $B) ($B' (($B _739) (($B _660) ((($C' _776) _9) 0))))) (($B ($B (_739 _663))) ((($C' ($C' _676)) (($B ($B (_676 "combinator conversion "))) (($B ($B (_635 6))) (($B ($B _621)) _770)))) "ms")))))) (($B ($B _643)) (($B $P) (($C _583) (_574 "main"))))))))) (_678 ($T ((($C' ($C' $O)) ((($C' $B) $P) _403)) $K))))))) (($A :3 (($B (_641 _591)) (($B (($C' _592) ((($C' _765) (($B _693) (_701 ((_740 _781) (_633 "--"))))) 1))) (($B (_739 _7)) _4)))) (($A :4 ($T (($C ((($C' $C') (($B $S) ($C $C))) (($B ($B $Y)) (($B ($B ($B _565))) (($C' ($C' _678)) (($B ($B $T)) ((($C' ($C' ($C' ($C' $O)))) (($B ($B (($C' $B) $P))) ($B _5))) $K))))))) (($B (($S' _739) (($B _736) (($B (_739 _785)) (($B (_676 "not found ")) _580))))) ($C _566))))) (($A :5 ((($C' $C) ((($S' $C) ((($C' ($C' $S')) (($S $P) ((($S' ($C' $B)) (($B ($B _7)) _5)) _5))) ($BK $K))) ((($C' ($S' $C)) ((($C' ($C' $C)) (($B (($C' $C) (($B ($P _7)) $K))) ((($C' $B) _5) _402))) ((($S' _739) (($B _736) (($B (_739 _785)) (_676 "primlookup: ")))) (($C (_715 _633)) _6)))) $K))) (_785 "trans: impossible"))) (($A :6 (($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)
\ No newline at end of file
+849
+(($A :0 ((_643 _592) (($B ((($S' ($C ((($C' ($S' _643)) (($B ($C _2)) _575)) (($B ($B (_643 _672))) ((($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 _644)) ((($C' $B) (($B _741) (($B _662) ((($C' _778) _9) 0)))) (($B (_741 _665)) (($B (_678 "top level defns: ")) _623)))))))) ((($S' $B) ($B' (($B ($C' $B)) (($B $B') (($B ($B _644)) ((($C' $B) (($B _741) (($B _662) ((($C' _778) _9) 1)))) (_661 ($T (($B ($B (_741 _665))) ((($C' $B) (($B _678) ((($C' _678) _581) " = "))) (($C _400) $K))))))))))) ((($C' $B) ((($S' $C') (($B $C') (($B $C') _10))) ((($S' $B) (($B ($C' ($C' _644))) ((($C' $B) ($B' (($B _741) (($B _667) _12)))) (($B _678) ((($C' _678) (($B (_678 _1)) _623)) (($O 10) $K)))))) (($B ($B (_643 _672))) ((($C' $B) ($B' (($B _741) (($B _662) ((($C' _778) _9) 0))))) (($B ($B (_741 _665))) ((($C' ($C' _678)) (($B ($B (_678 "final pass "))) (($B ($B (_637 6))) (($B ($B _623)) _772)))) "ms"))))))) _3))))) ((($C' ($C' $C)) (($B (($C' $C) (($B ($C _683)) _400))) (($C _696) (_712 0)))) $K))) (($B ($C $B)) (($B ($B ($C $B))) (($B ($B $BK)) (($B ($B (($C' $B) (($B _742) (($B _678) ((($C' _678) (($B (_678 "(($A :")) _623)) (($O 32) $K))))))) ((($C' $B) (($B ($C' _742)) ($B _400))) (($B (_742 (_678 ") "))) (($C _742) (_678 (($O 41) $K)))))))))))) $T)) (($B $Y) ((($C' ($C' $S)) ((($C' ($C' $S)) ((($C' $B) $P) ((($S' ($C' $B)) ($B _375)) $I))) ($BK $K))) $K))))) (($B (($S' _741) (($B _738) (($B (_741 _787)) (($B (_678 "main: findIdent: ")) _581))))) (($C' _611) _578)))) _618))) (($B ($B _615)) ((($C' $B) (($B _680) (($B $T) (($B ($C $B)) (($B ($B $BK)) ((($C' ($C' ($C' $O))) ($B (($C' $P) _578))) $K)))))) (($C _696) (_712 0))))))) ($T $A))) ($T $K))) $I)) (($B (_741 _374)) (($B (_741 _575)) (($B (_678 (($O 95) $K))) _623)))))))) (($S (($S ((($S' _8) (($B _695) (_682 (_635 "-v")))) ((_711 _635) "-r"))) (($B (_676 (($O 46) $K))) (($B _740) (_681 ((_700 _763) "-i")))))) (($B (_741 _707)) ((($C' _678) (($B _740) (_681 ((_700 _763) "-o")))) (($O "out.comb") $K))))) (($B (($S (($C ((($C' _774) _695) 1)) (_787 "Usage: mhs [-v] [-r] [-iPATH] [-oFILE] ModuleName"))) _707)) (_682 ((_742 _783) ((_742 (_635 (($O 45) $K))) (_693 1))))))) (_703 ((_742 _783) (_635 "--")))))) (($A :1 "v3.4\10&") (($A :2 ((($S' ($S' _643)) _17) (($B ($B ($B (_643 _672)))) ((($C' ($C' $B)) (($B ($B ($C' (($S' _643) (($B _645) (_734 _220)))))) (($B ($B ($B ($B $T)))) (($B ($B ($B ($B (_643 _672))))) ((($C' $B) (($B ($C' $B)) (($B ($B ($C' _644))) ((($C' $B) ($B' (($B _741) (($B _662) ((($C' _778) _9) 0))))) (($B ($B (_741 _665))) ((($C' ($C' _678)) (($B ($B (_678 "combinator conversion "))) (($B ($B (_637 6))) (($B ($B _623)) _772)))) "ms")))))) (($B ($B _645)) (($B $P) (($C _584) (_575 "main"))))))))) (_680 ($T ((($C' ($C' $O)) ((($C' $B) $P) _403)) $K))))))) (($A :3 (($B (_643 _592)) (($B (($C' _593) ((($C' _767) (($B _695) (_703 ((_742 _783) (_635 "--"))))) 1))) (($B (_741 _7)) _4)))) (($A :4 ($T (($C ((($C' $C') (($B $S) ($C $C))) (($B ($B $Y)) (($B ($B ($B _565))) (($C' ($C' _680)) (($B ($B $T)) ((($C' ($C' ($C' ($C' $O)))) (($B ($B (($C' $B) $P))) ($B _5))) $K))))))) (($B (($S' _741) (($B _738) (($B (_741 _787)) (($B (_678 "not found ")) _581))))) ($C _566))))) (($A :5 ((($C' $C) ((($S' $C) ((($C' ($C' $S')) (($S $P) ((($S' ($C' $B)) (($B ($B _7)) _5)) _5))) ($BK $K))) ((($C' ($S' $C)) ((($C' ($C' $C)) (($B (($C' $C) (($B ($P _7)) $K))) ((($C' $B) _5) _402))) ((($S' _741) (($B _738) (($B (_741 _787)) (_678 "primlookup: ")))) (($C (_717 _635)) _6)))) $K))) (_787 "trans: impossible"))) (($A :6 (($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)
\ No newline at end of file
--- a/lib/Prelude.hs
+++ b/lib/Prelude.hs
@@ -11,7 +11,8 @@
module Data.Maybe,
module Data.Tuple,
module System.IO,
- module Text.String
+ module Text.String,
+ _noMatch,
) where
import Control.Error
import Data.Bool
@@ -24,3 +25,9 @@
import Data.Tuple
import System.IO
import Text.String
+
+-- Called on pattern match failure.
+_noMatch :: forall a . [Char] -> Int -> Int -> a
+_noMatch fn l c = error $ "no match at " ++
+ if null fn then "no location" else
+ showString fn ++ ": " ++ "line " ++ showInt l ++ ", col " ++ showInt c
--- a/src/MicroHs/Desugar.hs
+++ b/src/MicroHs/Desugar.hs
@@ -43,7 +43,7 @@
in zipWith dsConstr (enumFrom 0) cs
Newtype _ c _ -> [ (qualIdent mn c, Lit (LPrim "I")) ]
Type _ _ -> []
- Fcn f eqns -> [(f, dsEqns eqns)]
+ Fcn f eqns -> [(f, dsEqns (getSLocIdent f) eqns)]
Sign _ _ -> []
Import _ -> []
ForImp ie i _ -> [(i, Lit $ LForImp ie)]
@@ -55,7 +55,7 @@
dsBind :: Ident -> EBind -> [LDef]
dsBind v abind =
case abind of
- BFcn f eqns -> [(f, dsEqns eqns)]
+ BFcn f eqns -> [(f, dsEqns (getSLocIdent f) eqns)]
BPat p e ->
let
de = (v, dsExpr e)
@@ -63,14 +63,14 @@
in de : ds
BSign _ _ -> []
-dsEqns :: [Eqn] -> Exp
-dsEqns eqns =
+dsEqns :: SLoc -> [Eqn] -> Exp
+dsEqns loc eqns =
case eqns of
Eqn aps _ : _ ->
let
vs = allVarsBind $ BFcn (mkIdent "") eqns
xs = take (length aps) $ newVars "q" vs
- ex = runS (vs ++ xs) (map Var xs) [(map dsPat ps, dsAlts alts, hasGuards alts) | Eqn ps alts <- eqns]
+ ex = runS loc (vs ++ xs) (map Var xs) [(map dsPat ps, dsAlts alts, hasGuards alts) | Eqn ps alts <- eqns]
in foldr Lam ex xs
_ -> impossible
@@ -152,10 +152,10 @@
case aexpr of
EVar i -> Var i
EApp f a -> App (dsExpr f) (dsExpr a)
- ELam xs e -> dsLam xs e
+ ELam xs e -> dsLam (getSLocExpr aexpr) xs e
ELit _ (LChar c) -> Lit (LInt (ord c))
ELit _ l -> Lit l
- ECase e as -> dsCase e as
+ ECase e as -> dsCase (getSLocExpr aexpr) e as
ELet ads e -> dsBinds ads (dsExpr e)
ETuple es -> Lam (mkIdent "$f") $ foldl App (Var $ mkIdent "$f") $ map dsExpr es
EIf e1 e2 e3 ->
@@ -199,12 +199,12 @@
xs = [mkIdent ("x" ++ showInt i) | i <- enumFromTo 1 n ]in App tup (foldr Lam (Var (xs !! m)) xs)
-dsLam :: [EPat] -> Expr -> Exp
-dsLam ps e =
+dsLam :: SLoc -> [EPat] -> Expr -> Exp
+dsLam loc ps e =
let
vs = allVarsExpr (ELam ps e)
xs = take (length ps) (newVars "l" vs)
- ex = runS (vs ++ xs) (map Var xs) [(map dsPat ps, dsAlts $ oneAlt e, False)]
+ ex = runS loc (vs ++ xs) (map Var xs) [(map dsPat ps, dsAlts $ oneAlt e, False)]
in foldr Lam ex xs
-- Handle special syntax for lists and tuples
@@ -266,12 +266,9 @@
----------------
-dsCase :: Expr -> [ECaseArm] -> Exp
-dsCase ae as =
- let
- r = runS (allVarsExpr (ECase ae as)) [dsExpr ae] [([dsPat p], dsAlts alts, hasGuards alts) | (p, alts) <- as]
- in --trace (showExp r) $
- r
+dsCase :: SLoc -> Expr -> [ECaseArm] -> Exp
+dsCase loc ae as =
+ runS loc (allVarsExpr (ECase ae as)) [dsExpr ae] [([dsPat p], dsAlts alts, hasGuards alts) | (p, alts) <- as]
type MState = [Ident] -- supply of unused variables.
@@ -291,13 +288,13 @@
put (tail is)
S.return (head is)
-runS :: [Ident] -> [Exp] -> Matrix -> Exp
-runS used ss mtrx =
+runS :: SLoc -> [Ident] -> [Exp] -> Matrix -> Exp
+runS loc used ss mtrx =
let
supply = newVars "x" used
ds xs aes =
case aes of
- [] -> dsMatrix eMatchErr (reverse xs) mtrx
+ [] -> dsMatrix (eMatchErr loc) (reverse xs) mtrx
e:es -> letBind (S.return e) $ \ x -> ds (x:xs) es
in S.evalState (ds [] ss) supply
@@ -351,8 +348,9 @@
narms <- S.mapM oneGroup grps
S.return $ mkCase i narms ndflt
-eMatchErr :: Exp
-eMatchErr = App (Lit (LPrim "error")) (Lit (LStr "no match"))
+eMatchErr :: SLoc -> Exp
+eMatchErr (SLoc fn l c) =
+ App (App (App (Var (mkIdent "Prelude._noMatch")) (Lit (LStr fn))) (Lit (LInt l))) (Lit (LInt c))
-- If the first expression isn't a variable/literal, then use
-- a let binding and pass variable to f.
--
⑨