[code cleaning
martin.hofmann@uni-bamberg.de**20090901151838] hunk ./src/RuleDevelopment/UniProp.hs 30
-mkFoldCall cr (v,fios) = (liftM (:[])) . fromJust . msum $ [ mbFilter cr (v,fios)
-                                                   , mbMap cr (v,fios)
-                                                   ,Just $ mkFold cr (v,fios)]
+mkFoldCall cr (v,fios) = (liftM (:[])) . fromJust . msum $ 
+                        [ mbFilter cr (v,fios)
+                        , mbMap cr (v,fios)
+                        ,Just $ mkFold cr (v,fios)]
hunk ./src/RuleDevelopment/UniProp.hs 43
-
hunk ./src/RuleDevelopment/UniProp.hs 46
-                let pios = (++) (map (makeFilterIO False) f)(map (makeFilterIO True) t)
-                prednm  <- addIO.rules $ pios
-                predcr  <- coverAll prednm
+                llogNO (text "UniProp for Cata applicable, 'filter' detected!")
+                afnm  <- addIO . rules $ (++) (mkFIO False f) (mkFIO True t)
+                afcr  <- coverAll afnm
+                -- prepare IO examples for the predicate/argument function (af)
hunk ./src/RuleDevelopment/UniProp.hs 51
---                --filter :: (a -> Bool) -> [a] -> [a]
-                let pExp = (mkTConE prednm) . unArrowT . typeOf . crul $ predcr
-                let fExp = foldTAppE (mkTConE 'filter (concatMap (unArrowT . typeOf . crul) [predcr, cr])) [pExp, head.lhs.crul $ cr]
+--              -- filter :: (a -> Bool) -> [a] -> [a]
+                -- filter :: ^   pty   ^ -> ^  atys  ^
+                let afty = [typeOf . crul $ afcr]                
+                let atys = unArrowT . typeOf . crul $ cr
+                
+                -- f x0 = filter fun1   x0
+                --               ^pExp^
+                --        ^ fExp          ^                                
+                let pExp = (mkTConE afnm) afty
+                let fExp = foldTAppE 
+                            (mkTConE 'filter (afty ++ atys))
+                            [pExp, head.lhs.crul $ cr]
+                            
hunk ./src/RuleDevelopment/UniProp.hs 65
-    
-                return (S.fromList [cr',predcr],[(name cr',prednm, LT)])
+                -- build the 'filter expression'
+                return (S.fromList [cr',afcr],[(name cr',afnm, LT)])
hunk ./src/RuleDevelopment/UniProp.hs 69
-    where    
-    makeFilterIO b r = let n = if b then 'True else 'False 
-                 in rule (take 1 (lhs r))(mkTConE n [ConT ''Bool])
+    where  
+    mkFIO = map . (\b r -> let n = if b then 'True else 'False 
+                           in rule (take 1 (lhs r))(mkTConE n [ConT ''Bool]))
hunk ./src/RuleDevelopment/UniProp.hs 79
-        afnm  <- addIO . rules . nub . (map makeMapIO) $ ios
+        llogNO (text "UniProp for Cata applicable, 'map' detected!")
+        afnm  <- addIO . rules . nub . (map mkMapIO) $ ios
hunk ./src/RuleDevelopment/UniProp.hs 84
---      map :: (a -> b) -> [a] -> [b]
-        let afExp = (mkTConE afnm) . unArrowT . typeOf . crul $ afcr
-        let mExp = foldTAppE (mkTConE 'map (concatMap (unArrowT . typeOf . crul) [afcr, cr])) [afExp, head.lhs.crul $ cr]
+        -- map :: (a -> b) -> [a] -> [b]
+        -- map :: ^   afty   ^ -> ^  atys  ^
+        let afty = [typeOf . crul $ afcr]                
+        let atys = unArrowT . typeOf . crul $ cr
+        
+        
+        -- f x0 = map fun1   x0
+        --            ^afExp^
+        --        ^ mExp      ^  
+        let afExp = (mkTConE afnm) afty
+        let mExp = foldTAppE 
+                    (mkTConE 'map (afty ++ atys))
+                    [afExp, head.lhs.crul $ cr]
hunk ./src/RuleDevelopment/UniProp.hs 101
-    makeMapIO r = rule (take 1 (lhs r)) (head . subterms . rhs $  r)
+    mkMapIO r = rule (take 1 (lhs r)) (head . subterms . rhs $  r)
hunk ./src/RuleDevelopment/UniProp.hs 103
-sndArgIsOut r = ((lhs r) !! 1) == (rhs r)
-
-sndArgConsed r =  
-    case rhs r of
-       TListE (x:xs) t -> ((lhs r) !! 1) == TListE xs t
-       t@(TAppE _ _ _) ->
-         case unfoldTAppE t of
-            [TConE n _, _, xs] -> isCons n  && ((lhs r) !! 1) == xs
-            _owise -> False
-       _owise -> False
-
-                                          
+                                         
hunk ./src/RuleDevelopment/UniProp.hs 105
-mkFold cr (v,fios) =  do 
-    llogNO (text "UniProp applicable!")
-    subfnm    <- addIO.rules $ fios
+mkFold cr (v,ios) =  do 
+    llogNO (text "UniProp for Cata applicable, fallback to 'foldr'!")
+    afnm  <- addIO . rules $ ios
+    afcr  <- coverAll afnm
hunk ./src/RuleDevelopment/UniProp.hs 110
-    let alpha  = typeOf . head . lhs. head $ fios
-    let alstty = mkListT alpha
-    let beta   = typeOf v
-    let fty    = mkArrowT [alpha, beta, beta]
-    let fExp   = mkTConE subfnm [alpha, beta, beta]
-    let fldarg = head.lhs.crul $ cr
-    let fldExp = foldTAppE (mkTConE 'foldr [fty,beta,alstty,beta]) [fExp, v, fldarg]
-    let cr' = modifycrul cr (\r -> rule (lhs r) fldExp)
+    -- foldr :: (a -> b -> b) -> b -> [a] -> b
+    -- foldr :: ^   afty    ^ -> ^  atys     ^
+    let afty = [typeOf . crul $ afcr]                
+    let atys = typeOf v : (unArrowT . typeOf . crul $ cr)
+--        
+--        
+--        -- f x0 = foldr fun1    v x0
+--        --              ^afExp^
+--        --        ^ fExp         ^  
+    let afExp = (mkTConE afnm) afty
+    let fExp  = foldTAppE 
+                    (mkTConE 'foldr (afty ++ atys))
+                    [afExp, v, head.lhs.crul $ cr]
+    let cr' = modifycrul cr (\r -> rule (lhs r) fExp)
hunk ./src/RuleDevelopment/UniProp.hs 125
+    return (S.fromList [cr',afcr],[(name cr',afnm, EQ)])
+    
hunk ./src/RuleDevelopment/UniProp.hs 128
-    llogIN (text "Make Catamorphism:" <^> pretty cr')
-    mkCallsAndDeps subfnm fios cr'
-
-
-mkCallsAndDeps :: Name -> [Rule] -> CovrRule ->  IM (CovrRules,[Call])
-mkCallsAndDeps subnm ios foldcr = do 
-    subcr     <- coverAll subnm
-    let calls = [((name foldcr),subnm, EQ)]
-    return (S.fromList [foldcr,subcr],calls)
----- for detecting fold as filter and inserting if_then_else
---    case partition idOn2ndArg ios of
---        (f@(_:_),t@(_:_)) -> do 
---        -- 
---            let fios = (++) (map (makeIO False) f)(map (makeIO True) t)
---            filternm  <- addIO.rules $ fios
---            filtercr  <- coverAll filternm
---            let subcr' =  modifycrul subcr (mkCond filternm)
---            return [(S.fromList [foldcr,subcr',filtercr],(subnm,filternm, LT):calls)]
---        otherwise         -> return [(S.fromList [foldcr,subcr],calls)]
---    where
---    makeIO b r = let n = if b then 'True else 'False 
---                 in rule (take 1 (lhs r))(mkTConE n [ConT ''Bool])
---    idOn2ndArg r = ((lhs r) !! 1) == (rhs r)
---    mkCond n r = let [x,xs] = lhs r
---                     if_ = mkTAppE (mkTConE n [typeOf x, ConT ''Bool]) x
---                     then_ =mkTInfixE (mkTConE '(:) [typeOf x ,typeOf xs]) x xs
---                     else_ = xs
---                     rhs' = mkTCondE if_ then_ else_
---                 in rule (lhs r) rhs'
-     
hunk ./src/RuleDevelopment/UniProp.hs 153
+-- check wether a rule is just a projection on the second argument
+sndArgIsOut r = ((lhs r) !! 1) == (rhs r)
+
+-- check wether the second argument of a rule occurs unchanged in the output 
+-- after a cons
+sndArgConsed r =  
+    case rhs r of
+       TListE (x:xs) t -> ((lhs r) !! 1) == TListE xs t
+       t@(TAppE _ _ _) ->
+         case unfoldTAppE t of
+            [TConE n _, _, xs] -> isCons n  && ((lhs r) !! 1) == xs
+            _owise -> False
+       _owise -> False
+       