[implement irrefutable patterns
John Meacham <john@repetae.net>**20061212084716] hunk ./E/FromHs.hs 41
+import FrontEnd.Desugar(patVarNames)
hunk ./E/FromHs.hs 82
---newVars :: MonadState Int m => [E] -> m [TVr]
+newVars :: UniqueProducer m => [E] -> m [TVr]
hunk ./E/FromHs.hs 132
-simplifyHsPat (HsPIrrPat p) = simplifyHsPat p -- TODO irrefutable patterns!
+simplifyHsPat (HsPIrrPat p) = HsPIrrPat $ simplifyHsPat p -- TODO irrefutable patterns!
hunk ./E/FromHs.hs 166
-    v (HsMatch _ _ ps rhs wh) = (map simplifyHsPat ps,rhs,wh)
+    v (HsMatch _ _ ps rhs wh) = (ps,rhs,wh)
+    --v (HsMatch _ _ ps rhs wh) = (map simplifyHsPat ps,rhs,wh)
hunk ./E/FromHs.hs 170
-    v (HsAlt _ p rhs wh) = ([simplifyHsPat p],rhs,wh)
+    v (HsAlt _ p rhs wh) = ([p],rhs,wh)
+--    v (HsAlt _ p rhs wh) = ([simplifyHsPat p],rhs,wh)
hunk ./E/FromHs.hs 643
-    f (HsPIrrPat p) = f p -- TODO irrefutable patterns!
+    -- remove some redundant irrefutable markings
+    f (HsPIrrPat p@HsPVar {}) = f p
+    f (HsPIrrPat p@HsPWildCard) = f p
+    f (HsPIrrPat p@HsPIrrPat {}) = f p
+    f (HsPIrrPat p) = do
+        [bv] <- newVars [getType b]
+        let f n = do
+            v <- convertVar (toName Name.Val n)
+            fe <- convertMatches [EVar bv] [([p],const (EVar v))] (EError "Irrefutable pattern match failed" (getType v))
+            return (v,fe)
+        zs <- mapM f (patVarNames p)
+        return (HsPWildCard,eLet bv b . eLetRec zs)
hunk ./E/FromHs.hs 711
-            let patternGroups = groupUnder (isStrictPat . fst3) pps
+            let patternGroups = groupUnder (isHsPWildCard . fst3) pps
hunk ./E/FromHs.hs 890
-isStrictPat HsPVar {} = False
-isStrictPat HsPWildCard = False
-isStrictPat (HsPAsPat _ p) = isStrictPat p
-isStrictPat (HsPIrrPat p) = isStrictPat p  -- TODO irrefutable patterns
-isStrictPat _ = True
hunk ./FrontEnd/Desugar.hs 37
-module FrontEnd.Desugar ( doToExp, desugarHsModule, desugarHsStmt) where
+module FrontEnd.Desugar (doToExp, desugarHsModule, desugarHsStmt, patVarNames) where
hunk ./FrontEnd/Desugar.hs 252
-patVarNames (HsPInfixApp pat1 conName pat2)
-   = patVarNames pat1 ++ patVarNames pat2
-patVarNames (HsPApp conName pats)
-   = concatMap patVarNames pats
-patVarNames (HsPTuple pats)
-   = concatMap patVarNames pats
-patVarNames (HsPUnboxedTuple pats)
-   = concatMap patVarNames pats
-patVarNames (HsPList pats)
-   = concatMap patVarNames pats
-patVarNames (HsPParen pat)
-   = patVarNames pat
+patVarNames (HsPInfixApp pat1 conName pat2) = patVarNames pat1 ++ patVarNames pat2
+patVarNames (HsPApp conName pats) = concatMap patVarNames pats
+patVarNames (HsPTuple pats) = concatMap patVarNames pats
+patVarNames (HsPUnboxedTuple pats) = concatMap patVarNames pats
+patVarNames (HsPList pats) = concatMap patVarNames pats
+patVarNames (HsPParen pat) = patVarNames pat
hunk ./FrontEnd/Desugar.hs 259
-patVarNames (HsPAsPat asName pat)
-   = asName : patVarNames pat
+patVarNames (HsPAsPat asName pat) = asName : patVarNames pat
hunk ./FrontEnd/Desugar.hs 261
-patVarNames (HsPIrrPat pat)
-   = patVarNames pat
+patVarNames (HsPIrrPat pat) = patVarNames pat
hunk ./FrontEnd/Tc/Main.hs 426
-tiPat (HsPIrrPat p) typ = tiPat p typ
+tiPat (HsPIrrPat p) typ = do
+    (p,ns) <- tiPat p typ
+    return (HsPIrrPat p,ns)