[move a lot of pattern simplification into the type checker. don't create wildcard bindings when converting Hs -> E
John Meacham <john@repetae.net>**20061213033921] hunk ./E/FromHs.hs 45
+import FrontEnd.Tc.Main(isTypePlaceholder)
hunk ./E/FromHs.hs 120
-simplifyHsPat (HsPInfixApp p1 n p2) = HsPApp n [simplifyHsPat p1, simplifyHsPat p2]
-simplifyHsPat (HsPParen p) = simplifyHsPat p
-simplifyHsPat (HsPTuple ps) = HsPApp (toTuple (length ps)) (map simplifyHsPat ps)
-simplifyHsPat (HsPUnboxedTuple ps) = HsPApp (nameName $ unboxedNameTuple DataConstructor (length ps)) (map simplifyHsPat ps)
-simplifyHsPat HsPNeg {} = error "E.FromHs: HsPNeg exists"
---simplifyHsPat (HsPLit (HsString s)) | True || length s <= 3 = simplifyHsPat (HsPList (map f s)) where
---    f c = HsPLit (HsChar c)
-simplifyHsPat (HsPAsPat n p) = HsPAsPat n (simplifyHsPat p)
-simplifyHsPat (HsPTypeSig _ p _) = simplifyHsPat p
-simplifyHsPat (HsPList ps) = pl ps where
-    pl [] = HsPApp (nameName $ dc_EmptyList) []
-    pl (p:xs) = HsPApp (nameName $ dc_Cons) [simplifyHsPat p, pl xs]
-simplifyHsPat (HsPApp n xs) = HsPApp n (map simplifyHsPat xs)
-simplifyHsPat (HsPIrrPat p) = HsPIrrPat $ simplifyHsPat p -- TODO irrefutable patterns!
-simplifyHsPat p@HsPVar {} = p
-simplifyHsPat p@HsPLit {} = p
-simplifyHsPat p = error $ "simplifyHsPat: " ++ show p
hunk ./E/FromHs.hs 151
-    --v (HsMatch _ _ ps rhs wh) = (map simplifyHsPat ps,rhs,wh)
hunk ./E/FromHs.hs 154
---    v (HsAlt _ p rhs wh) = ([simplifyHsPat p],rhs,wh)
hunk ./E/FromHs.hs 399
-    cDecl (HsPatBind sl p (HsUnGuardedRhs exp) []) | (HsPVar n) <- simplifyHsPat p, n == sillyName' = do
+    cDecl (HsPatBind sl (HsPVar n) (HsUnGuardedRhs exp) []) | n == sillyName' = do
hunk ./E/FromHs.hs 402
+    cDecl (HsPatBind sl p rhs wh) | (HsPVar n) <- p = do
+        let name = toName Name.Val n
+        (var,ty,lamt) <- convertValue name
+        rhs <- cRhs sl rhs
+        lv <- hsLetE wh rhs
+        return [(name,var,lamt lv)]
+    cDecl (HsPatBind sl p rhs wh) | (HsPVar n) <- p = do
+        let name = toName Name.Val n
+        (var,ty,lamt) <- convertValue name
+        rhs <- cRhs sl rhs
+        lv <- hsLetE wh rhs
+        return [(name,var,lamt lv)]
hunk ./E/FromHs.hs 415
-    cDecl (HsPatBind sl p rhs wh) | (HsPVar n) <- simplifyHsPat p = do
+    cDecl (HsPatBind sl p rhs wh) | (HsPVar n) <- p = do
hunk ./E/FromHs.hs 421
-    cDecl (HsFunBind [(HsMatch sl n ps rhs wh)]) | ps' <- map simplifyHsPat ps, all isHsPVar ps' = do
+    cDecl (HsFunBind [(HsMatch sl n ps rhs wh)]) | all isHsPVar ps = do
hunk ./E/FromHs.hs 426
-        lps <- lp  ps' lv
+        lps <- lp ps lv
hunk ./E/FromHs.hs 464
-    cExpr (HsLambda sl ps e) | all isHsPVar ps' = do
+    cExpr (HsLambda sl ps e) | all isHsPVar ps = do
hunk ./E/FromHs.hs 466
-        lp ps' e
-      where ps' = map simplifyHsPat ps
+        lp ps e
hunk ./E/FromHs.hs 556
-        return (map simplifyHsPat ps,elet . cg )
+        return (ps,elet . cg )
hunk ./E/FromHs.hs 606
+patVar ::
+    Monad m
+    => HsPat -- ^ the pattern
+    -> E     -- ^ the type of the expression
+    -> Ce m (HsPat,TVr)  -- ^ a new pattern and a binding variable
+patVar HsPWildCard t = return (HsPWildCard,tvr { tvrType = t })
+patVar (HsPVar n) t | isTypePlaceholder n = return (HsPWildCard,tvr { tvrType = t })
+patVar (HsPAsPat n p) t | not (isTypePlaceholder n) = do
+    nn <- convertVar (toName Name.Val n)
+    return (p,nn)
+patVar (HsPAsPat n p) t | isTypePlaceholder n = patVar p t
+patVar p t = do
+    [nv] <- newVars [t]
+    return (p,nv)
+
+
hunk ./E/FromHs.hs 628
-    f (HsPInfixApp p1 n p2) = f $ HsPApp n [p1,p2]
-    f (HsPParen p) = f p
-    f (HsPTuple ps) = f (HsPApp (toTuple (length ps)) ps)
-    f (HsPUnboxedTuple ps) = f $ HsPApp (nameName $ unboxedNameTuple DataConstructor (length ps)) ps
hunk ./E/FromHs.hs 629
-    f HsPNeg {} = error "E.FromHs: HsPNeg exists"
-    f HsPRec {} = error "E.FromHs: HsPRec exists"
+    f (HsPVar n) | isTypePlaceholder n = return (HsPWildCard,id)
+    f (HsPAsPat n p) | isTypePlaceholder n = f p
hunk ./E/FromHs.hs 632
-    f (HsPList ps) = f (pl ps) where
-        pl [] = HsPApp (nameName $ dc_EmptyList) []
-        pl (p:xs) = HsPApp (nameName $ dc_Cons) [p, pl xs]
hunk ./E/FromHs.hs 635
-        return (HsPWildCard,eLet v b)
+        return (HsPWildCard,if EVar v /=  b then eLet v b else id)
hunk ./E/FromHs.hs 639
-        return (p',eLet v b . g')
+        return (p',(if EVar v /= b then eLet v b else id) . g')
hunk ./E/FromHs.hs 647
-
-    -- 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
-        (lbv,bv) <- varify b
-        let f n = do
-            v <- convertVar (toName Name.Val n)
-            fe <- convertMatches [bv] [([p],const (EVar v))] (EError "Irrefutable pattern match failed" (getType v))
-            return (v,fe)
-        zs <- mapM f (patVarNames p)
-        return (HsPWildCard,lbv . eLetRec zs)
+    f (HsPIrrPat p) = f p >>= \ (p',fe) -> case p' of
+        HsPWildCard -> return (p',fe)
+        _ -> do
+            (lbv,bv) <- varify b
+            let f n = do
+                v <- convertVar (toName Name.Val n)
+                fe <- convertMatches [bv] [([p],const (EVar v))] (EError "Irrefutable pattern match failed" (getType v))
+                return (v,fe)
+            zs <- mapM f (patVarNames p)
+            return (HsPWildCard,lbv . eLetRec zs)
hunk ./E/FromHs.hs 744
-            | all (\ (c,_,_) -> isHsPApp c || isHsPString c) ps = do
-                let gps =  sortGroupUnderF (hsPPatName . fst3) (map ff ps)
-                    ff (HsPLit (HsString ""),ps,b) = ((HsPApp (nameName $ dc_EmptyList) []),ps,b)
-                    ff (HsPLit (HsString (c:cs)),ps,b) = ((HsPApp (nameName $ dc_Cons) [HsPLit (HsChar c),HsPLit (HsString cs)]),ps,b)
-                    ff x = x
+            | Just ps <- mapM pappConvert ps = do
+                let gps =  sortGroupUnderF (hsPatName . fst3) ps
hunk ./E/FromHs.hs 767
+        pappConvert (p@HsPApp {},x,y) = return (p,x,y)
+        pappConvert (HsPLit (HsString ""),ps,b) = return (HsPApp (nameName $ dc_EmptyList) [],ps,b)
+        pappConvert (HsPLit (HsString (c:cs)),ps,b) = return (HsPApp (nameName $ dc_Cons) [HsPLit (HsChar c),HsPLit (HsString cs)],ps,b)
+        pappConvert _ = fail "pappConvert"
+        isHsPString (HsPLit HsString {}) = True
+        isHsPString _ = False
hunk ./E/FromHs.hs 775
-hsPPatName p@HsPApp {} = hsPatName p
-hsPPatName (HsPLit (HsString "")) = nameName dc_EmptyList
-hsPPatName (HsPLit (HsString {})) = nameName dc_Cons
-
-isHsPString (HsPLit HsString {}) = True
-isHsPString _ = False
hunk ./FrontEnd/Tc/Main.hs 1
-module FrontEnd.Tc.Main (tiExpr, tiProgram, makeProgram ) where
+module FrontEnd.Tc.Main (tiExpr, tiProgram, makeProgram, isTypePlaceholder ) where
hunk ./FrontEnd/Tc/Main.hs 125
+isTypePlaceholder :: HsName -> Bool
+isTypePlaceholder (Qual (Module "Wild@") _) = True
+isTypePlaceholder (Qual (Module "As@") _) = True
+isTypePlaceholder _ = False
hunk ./FrontEnd/Tc/Main.hs 460
-    return (pl,mempty)
+    return (delistPats [],mempty)
hunk ./FrontEnd/Tc/Main.hs 466
-    return (pl,mempty)
+    return (delistPats [],mempty)
hunk ./FrontEnd/Tc/Main.hs 473
-    return (HsPList (fsts ps), mconcat (snds ps))
+    return (delistPats (fsts ps), mconcat (snds ps))
hunk ./FrontEnd/Tc/Main.hs 480
-    return (HsPList (fsts ps), mconcat (snds ps))
+    return (delistPats (fsts ps), mconcat (snds ps))
hunk ./FrontEnd/Tc/Main.hs 482
---tiPat HsPWildCard typ = unBox typ >> return (HsPWildCard, mempty)
hunk ./FrontEnd/Tc/Main.hs 501
+delistPats ps = pl ps where
+    pl [] = HsPApp (nameName $ dc_EmptyList) []
+    pl (p:xs) = HsPApp (nameName $ dc_Cons) [p, pl xs]
+