[add rules to library. make them apply to constructors properly
John Meacham <john@repetae.net>**20060210132540] hunk ./E/FromHs.hs 36
+import E.LetFloat(atomizeApps)
+import E.Eval(eval)
hunk ./E/FromHs.hs 56
+import qualified Stats
hunk ./E/FromHs.hs 253
-convertRules ::  Monad m => ClassHierarchy -> Map.Map Name Scheme -> DataTable -> [HsDecl] -> m [(String,[TVr],E,E)]
+convertRules ::  ClassHierarchy -> Map.Map Name Scheme -> DataTable -> [HsDecl] -> IO [(String,[TVr],E,E)]
hunk ./E/FromHs.hs 272
-        return [(hsDeclString pr,( snds (cs' ++ ts) ),smt $ sma e1,smt $ sma e2)]
+            e2' = deNewtype dataTable $ smt $ sma e2
+        e2 <- atomizeApps mempty Stats.theStats e2'
+        return [(hsDeclString pr,( snds (cs' ++ ts) ),eval $ smt $ sma e1,e2)]
hunk ./E/Rules.hs 26
+import Control.Monad.Trans
hunk ./E/Rules.hs 122
-{-
-printRule rule = do
-    putErrLn $ fromAtom (ruleName rule)
-    putErr $ "    " ++ render (ePretty (foldl EAp (EVar $ ruleHead rule) (ruleArgs rule)))
-    putErrLn $ " -> " ++ render (ePretty (ruleBody rule))
--}
+
hunk ./E/Rules.hs 128
-    putDocMLn CharIO.putStr $  (tshow n) <+> text "forall" <+> hsep (map p vs) <+> text "." <> text "\n"
+    putDocMLn CharIO.putStr $  (tshow n) <+> text "forall" <+> hsep (map p vs) <+> text "."
hunk ./E/Rules.hs 130
-        ty2 = pprint $ getType e2
+    --    ty2 = pprint $ getType e2
hunk ./E/Rules.hs 135
-    putDocMLn CharIO.putStr (indent 2 (text "::" <+> ty2))
+    --putDocMLn CharIO.putStr (indent 2 (text "::" <+> ty2))
hunk ./E/Rules.hs 187
-    f (r:_) | Just ss <- sequence (zipWith unify (ruleArgs r) xs) = ans ss where
-        ans ss = do
+    --f (r:_) | Just ss <- sequence (zipWith unify (ruleArgs r) xs) = ans ss where
+    f (r:rs) = case sequence (zipWith (match (ruleBinds r)) (ruleArgs r) xs) of
+        Just ss -> do
hunk ./E/Rules.hs 191
-            let b = substMap (Map.fromList [ (i,x) | ~(~(EVar (TVr { tvrIdent = i })),x) <- concat ss ]) (ruleBody r)
+            let b = substMap (Map.fromList [ (i,x) | (TVr { tvrIdent = i },x) <- concat ss ]) (ruleBody r)
hunk ./E/Rules.hs 193
-    f (_:rs) = f rs
-
-
+        Nothing -> do f rs
+            {-
+            liftIO $ do
+                putStrLn "rule didn't match:"
+                printRule r
+                putDocMLn CharIO.putStr (hsep (map (parens . pprint) xs))
+                putStrLn err
+            f rs
+            -}
hunk ./E/Rules.hs 221
-    rule = emptyRule {  ruleHead = head, ruleBinds = fvs, ruleArgs = args, ruleNArgs = length args, ruleBody = body, ruleName = toAtom $ "Rule." ++ name }
+    rule = emptyRule {  ruleHead = head, ruleBinds = fvs, ruleArgs = args, ruleNArgs = length args, ruleBody = body, ruleName = toAtom $ "Rule.User." ++ name }
hunk ./E/SSimplify.hs 467
-            Nothing | fopts FO.Rules -> applyRules (Info.fetch (tvrInfo v)) xs
+            Nothing | fopts FO.Rules -> do
+                applyRules (Info.fetch (tvrInfo v)) xs
+                --case z of
+                --    Just (x,xs) -> app (x,xs)
+                --    Nothing -> return Nothing
hunk ./E/SSimplify.hs 495
-            Just (x,xs) -> h x xs inb
+            Just (x,xs) -> didInline inb (x,xs) --h x xs inb
hunk ./E/SSimplify.hs 501
-            Just (x,xs) -> h x xs inb
+            Just (x,xs) -> didInline inb (x,xs) -- h x xs inb
hunk ./E/TypeCheck.hs 1
-module E.TypeCheck(eAp, sortStarLike, sortTypeLike,  sortTermLike, inferType, typeInfer, typeInfer') where
+module E.TypeCheck(eAp, sortStarLike, sortTypeLike,  sortTermLike, inferType, typeInfer, typeInfer', match) where
+
+import Monad(when,liftM)
+import qualified Data.Set as Set
+import Control.Monad.Writer
hunk ./E/TypeCheck.hs 18
-import Monad(when)
+import qualified Util.Seq as Seq
hunk ./E/TypeCheck.hs 270
+-- | find substitution that will transform the left term into the right one,
+-- only substituting for the vars in the list
+
+match :: Monad m => [TVr] -> E -> E -> m [(TVr,E)]
+match vs e1 e2 = liftM Seq.toList $ execWriterT (un e1 e2 () (0::Int)) where
+    bvs = Set.fromList (map tvrIdent vs)
+    un (EAp a b) (EAp a' b') mm c = do
+        un a a' mm c
+        un b b' mm c
+    un (EVar tvr@TVr { tvrIdent = i, tvrType = t}) b mm c | i `Set.member` bvs = do
+        --un t (getType b) mm c
+        tell (Seq.single (tvr,b))
+    un (EVar TVr { tvrIdent = i, tvrType =  t}) (EVar TVr {tvrIdent = j, tvrType =  u}) mm c | i == j = un t u mm c
+    un (ELam va ea) (ELam vb eb) mm c = lam va ea vb eb mm c
+    un (EPi va ea) (EPi vb eb) mm c = lam va ea vb eb mm c
+    un (EPrim s xs t) (EPrim s' ys t') mm c | length xs == length ys = do
+        sequence_ [ un x y mm c | x <- xs | y <- ys]
+        un t t' mm c
+    un (ESort x) (ESort y) mm c | x == y = return ()
+    un (ELit (LitInt x t1))  (ELit (LitInt y t2)) mm c | x == y = un t1 t2 mm c
+    un (ELit (LitCons n xs t))  (ELit (LitCons n' ys t')) mm c | n == n' && length xs == length ys = do
+        sequence_ [ un x y mm c | x <- xs | y <- ys]
+        un t t' mm c
+    un a b _ _ = fail $ "Expressions do not unify: " ++ show a ++ show b
+    lam va ea vb eb mm c = do
+        un ea eb mm c
+
hunk ./Main.hs 158
-    wdump FD.Rules $ printRules (hoRules ho)
+    --wdump FD.Rules $ printRules (hoRules ho)
hunk ./Main.hs 184
-    rs <- convertRules (hoClassHierarchy ho') allAssumps fullDataTable decls
-    {-
-    flip mapM_ rs $ \ (n,vs,e1,e2) -> do
-        let p v = parens $ pprint v <> text "::" <> pprint (getType v)
-        putDocM putStr $ (tshow n) <+> text "forall" <+> hsep (map p vs) <+> text "." <> text "\n"
-        let ty = case inferType dataTable [] e1 of
-                Left err -> vcat $ map text (intersperse "---" $ tail err)
-                Right ty -> pprint ty
-        let ty2 = case inferType dataTable [] e2 of
-                Left err -> vcat $ map text (intersperse "---" $ tail err)
-                Right ty -> pprint ty
-        putDocM putStr (indent 2 (pprint e1))
-        putDocM putStr $ text " ====>"
-        putDocM putStr (indent 2 (pprint e2))
-        putDocM putStr (indent 2 (text "::" <+> ty))
-        putDocM putStr (indent 2 (text "::" <+> ty2))
-        -}
-    let nrules = mconcat [ makeRule n vs head args e2 | (n,vs,e1,e2) <- rs, let (EVar head,args) = fromAp e1 ]
-
hunk ./Main.hs 190
+    rawRules <- convertRules (hoClassHierarchy ho') allAssumps fullDataTable decls
+    let nrules = mconcat [ makeRule n vs head args e2 | (n,vs,e1,e2) <- rawRules, let (EVar head,args) = fromAp e1 ]
hunk ./Main.hs 193
+    wdump FD.Rules $ printRules rules
+    printRules rules
hunk ./Main.hs 196
-    wdump FD.Rules $ printRules allRules
hunk ./Main.hs 297
-    return ho' { hoDataTable = dataTable, hoEs = Map.fromList [ (x,(y,z)) | (x,y,z) <- ds'], hoRules = rules, hoUsedIds = collectIds (ELetRec [ (b,c) | (_,b,c) <- ds'] Unknown) }
+    return ho' { hoDataTable = dataTable, hoEs = Map.fromList [ (x,(y,z)) | (x,y,z) <- ds'], hoRules = hoRules ho' `mappend` rules, hoUsedIds = collectIds (ELetRec [ (b,c) | (_,b,c) <- ds'] Unknown) }
hunk ./lib/List.hs 319
+{-# RULES "sort/sort"  forall  xs . sort (sort xs) = sort xs #-}
+{-# RULES "nub/nub"  forall  xs . nub (nub xs) = nub xs #-}
+
hunk ./lib/Prelude.hs 934
+
+
+{-# RULES "concat/Map" forall f xs . concat (map f xs) = concatMap f xs #-}
+{-# RULES "sequence/map" forall f xs . sequence (map f xs) = mapM f xs #-}
+{-# RULES "sequence_/map" forall f xs . sequence_ (map f xs) = mapM_ f xs #-}
+{-# RULES "++/emptyl"  forall xs . [] ++ xs = xs #-}
+{-# RULES "++/emptyr"  forall xs . xs ++ [] = xs #-}
+{-# RULES "++/tick"  forall  x xs ys . (x:xs) ++ ys = x:(xs ++ ys) #-}
+{-# RULES "++/refix"  forall  xs ys zs . (xs ++ ys) ++ zs = xs ++ (ys ++ zs) #-}
+{-# RULES "map/map"  forall f g xs . map f (map g xs) = map (\x -> f (g x)) xs #-}
+{-# RULES "concatMap/map"  forall f g xs . concatMap f (map g xs) = concatMap (\x -> f (g x)) xs #-}
+{-# RULES "concat/tick"  forall x xs . concat (x:xs) = x ++ concat xs #-}