[new list comprehension desugarer that is smarter about producing intermediate lists
John Meacham <john@repetae.net>**20060212070059] hunk ./FrontEnd/Desugar.hs 653
+f_map = nameName $ toUnqualified v_map
+f_foldr = nameName $ toUnqualified v_foldr
hunk ./FrontEnd/Desugar.hs 656
+f_filter = nameName $ toUnqualified v_filter
+f_and = nameName $ toUnqualified v_and
+con_cons = nameName $ toUnqualified dc_Cons
hunk ./FrontEnd/Desugar.hs 677
+hsApp e es = hsParen $ foldl HsApp (hsParen e) (map hsParen es)
+hsIf e a b = hsParen $ HsIf e a b
+patVar = HsVar newPatVarName
+
hunk ./FrontEnd/Desugar.hs 684
+    f (gen:HsQualifier q1:HsQualifier q2:ss)  = f (gen:HsQualifier (hsApp (HsVar f_and) [q1,q2]):ss)
hunk ./FrontEnd/Desugar.hs 687
-    f ((HsGenerator srcLoc pat e):ss) = hsParen $ HsApp (HsApp (HsVar f_concatMap)  (hsParen $ HsLambda srcLoc [HsPVar newPatVarName] kase)) e where
+    f ((HsGenerator srcLoc pat e):ss) | isHsPVar pat, Just exp' <- g ss = hsParen $ HsApp (HsApp (HsVar f_map)  (hsParen $ HsLambda srcLoc [pat] exp')) e
+    --f ((HsGenerator srcLoc pat e):[HsQualifier q]) | isHsPVar pat = hsParen $ HsApp (HsApp (HsVar f_filter)  (hsParen $ HsLambda srcLoc [pat] q) ) e
+    f ((HsGenerator srcLoc pat e):HsQualifier q:ss) | isHsPVar pat, Just exp' <- g ss =  hsApp (HsVar f_foldr)  [HsLambda srcLoc [pat,HsPVar newPatVarName] $ hsIf q (hsApp (HsCon con_cons) [exp',patVar]) (HsVar newPatVarName), HsList [],e]
+    f ((HsGenerator srcLoc pat e):ss) | isHsPVar pat = hsParen $ HsApp (HsApp (HsVar f_concatMap)  (hsParen $ HsLambda srcLoc [pat] (f ss))) e
+    f ((HsGenerator srcLoc pat e):HsQualifier q:ss) | isFailablePat pat || Nothing == (g ss) = hsParen $ HsApp (HsApp (HsVar f_concatMap)  (hsParen $ HsLambda srcLoc [HsPVar newPatVarName] kase)) e where
+        kase = HsCase (HsVar newPatVarName) [a1, a2 ]
+        a1 =  HsAlt srcLoc pat (HsGuardedAlts [HsGuardedAlt srcLoc q (f ss)]) []
+        a2 =  HsAlt srcLoc HsPWildCard (HsUnGuardedAlt $ HsList []) []
+    f ((HsGenerator srcLoc pat e):ss) | isFailablePat pat || Nothing == (g ss) = hsParen $ HsApp (HsApp (HsVar f_concatMap)  (hsParen $ HsLambda srcLoc [HsPVar newPatVarName] kase)) e where
hunk ./FrontEnd/Desugar.hs 699
+    f ((HsGenerator srcLoc pat e):ss)  = hsParen $ HsApp (HsApp (HsVar f_map)  (hsParen $ HsLambda srcLoc [HsPVar newPatVarName] kase)) e where
+        Just exp' = g ss
+        kase = HsCase (HsVar newPatVarName) [a1 ]
+        a1 =  HsAlt srcLoc pat (HsUnGuardedAlt exp') []
+    g [] = return exp
+    g (HsLetStmt ds:ss) = do
+        e <- g ss
+        return (hsParen (HsLet ds e))
+    g _ = Nothing
+
+-- patterns are
+-- failable - may fail to match
+-- refutable - may bottom out
+-- irrefutable - match no matter what
+-- failable is a subset of refutable
+
+
+isFailablePat p | isStrictPat p = f (openPat p) where
+    f (HsPTuple ps) = any isFailablePat ps
+    f _ = True
+isFailablePat _ = False
+
+isStrictPat p = f (openPat p) where
+    f HsPVar {} = False
+    f HsPWildCard = False
+    f (HsPIrrPat p) = False -- isStrictPat p  -- TODO irrefutable patterns
+    f _ = True
+
+
+openPat (HsPParen p) = openPat p
+openPat (HsPNeg p) = openPat p
+openPat (HsPAsPat _ p) = openPat p
+openPat (HsPTypeSig _ p _) = openPat p
+openPat (HsPInfixApp a n b) = HsPApp n [a,b]
+openPat p = p
hunk ./Main.hs 193
+    let initMap' = Map.fromList [ (tvrIdent tvr,EVar tvr) | tvr <- fsts $ Map.elems (hoEs ho)]
+
hunk ./Main.hs 198
+        lc <- return $ substMap initMap' lc
hunk ./Main.hs 221
+            Stats.tickStat stats stat'
hunk ./Main.hs 224
-            Stats.tickStat stats stat'
-            return e''
+            let (stat, e''') = SS.simplifyE sopt e''
+            Stats.tickStat stats stat
+            return e'''
hunk ./Main.hs 229
-            lc <- doopt mangle False stats "Float Inward..." (\stats x -> return (floatInward allRules x)) lc
+            --lc <- doopt mangle False stats "Float Inward..." (\stats x -> return (floatInward allRules x)) lc
hunk ./Main.hs 258
-                    let sopt = mempty { SS.so_superInline = True, SS.so_exports = inscope, SS.so_boundVars = Map.fromList [ (tvrIdent v,lc) | (v,lc) <- ds] `Map.union` smap, SS.so_rules = allRules, SS.so_dataTable = fullDataTable }
+                    let sopt = mempty { SS.so_exports = inscope, SS.so_boundVars = Map.fromList [ (tvrIdent v,lc) | (v,lc) <- ds] `Map.union` smap, SS.so_rules = allRules, SS.so_dataTable = fullDataTable }
hunk ./Name/Names.hs 106
+v_map = toName Val ("Prelude","map")
+v_and = toName Val ("Prelude","&&")
+v_filter = toName Val ("Prelude","filter")
+v_foldr = toName Val ("Prelude","foldr")
hunk ./lib/Prelude.hs 940
-{-# RULES "++/refix"      forall xs ys zs . (xs ++ ys) ++ zs = xs ++ (ys ++ zs) #-}
-{-# RULES "++/tick4"      forall x y z x' xs ys . (x:y:z:x':xs) ++ ys = x:y:z:x':(xs ++ ys) #-}
-{-# RULES "++/tick2"      forall x y xs ys . (x:y:xs) ++ ys = x:y:(xs ++ ys) #-}
+-- {-# RULES "++/refix"      forall xs ys zs . (xs ++ ys) ++ zs = xs ++ (ys ++ zs) #-}
+--{-# RULES "++/tick4"      forall x y z x' xs ys . (x:y:z:x':xs) ++ ys = x:y:z:x':(xs ++ ys) #-}
+--{-# RULES "++/tick2"      forall x y xs ys . (x:y:xs) ++ ys = x:y:(xs ++ ys) #-}
hunk ./lib/Prelude.hs 955
+{-# RULES "foldr/triple"  forall c n x y z. foldr c n [x,y,z] = c x (c y (c z n)) #-}
+{-# RULES "foldr/double"  forall k z x y . foldr k z [x,y] = k x (k y z) #-}
hunk ./lib/Prelude.hs 960
+{-# RULES "concatMap/++"  forall xs ys f . concatMap f (xs ++ ys) = concatMap f xs ++ concatMap f ys #-}
+{-# RULES "map/++"        forall xs ys f . map f (xs ++ ys) = map f xs ++ map f ys #-}
+{-# RULES "sequence_/++"  forall xs ys . sequence_ (xs ++ ys) = sequence_ xs >> sequence_ ys #-}
+{-# RULES "mapM_/++"      forall xs ys f . mapM_ f (xs ++ ys) = mapM_ f xs >> mapM_ f ys #-}
hunk ./lib/Prelude/IO.hs 49
+{-# RULES "putStr/++"      forall xs ys . putStr (xs ++ ys) = putStr xs >> putStr ys #-}