[attach rules to variables directly, seperate out built-in rules
John Meacham <john@repetae.net>**20050930034244] hunk ./E/Rules.hs 12
-    mapBodies
+    mapBodies,
+    hasBuiltinRule,
+    getARules,
+    arules,
+    ARules,
+    applyRules,
+    builtinRule
hunk ./E/Rules.hs 21
+import Data.Typeable
hunk ./E/Rules.hs 23
+import Monad(liftM)
hunk ./E/Rules.hs 49
+    ruleNArgs :: {-# UNPACK #-} !Int,
hunk ./E/Rules.hs 56
+instance Show Rule where
+    showsPrec _ r = showString (fromAtom $ ruleName r)
+
hunk ./E/Rules.hs 64
+    ruleNArgs = 0,
hunk ./E/Rules.hs 70
-newtype Rules = Rules (Map.Map TVr [Rule])
-    deriving(HasSize,Binary)
+newtype Rules = Rules (Map.Map Id [Rule])
+    deriving(HasSize)
hunk ./E/Rules.hs 73
+
+instance Binary Rules where
+    put_ h (Rules mp) = putNList h (concat $ Map.elems mp)
+    get h = do
+        rs <- getNList h
+        return $ fromRules rs
+
hunk ./E/Rules.hs 92
-ruleFreeVars (Rules r) tvr = case Map.lookup tvr r of
+ruleFreeVars (Rules r) tvr = case Map.lookup (tvrIdent tvr) r of
hunk ./E/Rules.hs 96
-ruleFreeVars' ::  Rules -> Int -> Set.Set Int
-ruleFreeVars' (Rules r) tvr = case Map.lookup (tVr tvr undefined) r of
+
+ruleFreeVars' ::  Rules -> Id -> Set.Set Int
+ruleFreeVars' (Rules r) tvr = case Map.lookup tvr r of
hunk ./E/Rules.hs 118
-fromRules rs = Rules $ Map.map snds $ Map.fromList $ sortGroupUnderF fst [ (ruleHead r,f r) | r <- rs ] where
+fromRules rs = Rules $ Map.map snds $ Map.fromList $ sortGroupUnderF fst [ (tvrIdent $ ruleHead r,f r) | r <- rs ] where
hunk ./E/Rules.hs 123
+getARules :: Monad m => Rules -> Id -> m ARules
+getARules (Rules mp) tvr = liftM arules (Map.lookup tvr mp)
hunk ./E/Rules.hs 126
-preludeError = nameValue "Prelude" "error"
-ruleError = toAtom "Rule.error/EError"
hunk ./E/Rules.hs 128
+
hunk ./E/Rules.hs 133
-    ans = case Map.lookup tvr rules of
+    ans = case Map.lookup (tvrIdent tvr) rules of
hunk ./E/Rules.hs 146
+-- | invarients for ARules
+-- sorted by number of arguments rule takes
+-- all hidden rule fields filled in
+
+newtype ARules = ARules [Rule]
+    deriving(Show,Typeable)
+
+arules xs = ARules (sortUnder ruleNArgs (map f xs)) where
+    f rule = rule { ruleNArgs = length  (ruleArgs rule) }
+
+
+applyRules :: [Rule] -> [E] -> IO (Maybe (E,[E]))
+applyRules rs xs = f rs where
+    lxs = length xs
+    f [] = return Nothing
+    f (r:_) | ruleNArgs r > lxs = return Nothing
+    f (r:_) | Just ss <- sequence (zipWith unify (ruleArgs r) xs) = ans ss where
+        ans ss = do
+            mtick (ruleName r)
+            let b = substMap (IM.fromList [ (i,x) | ~(~(EVar (TVr { tvrIdent = i })),x) <- concat ss ]) (ruleBody r)
+            return $ Just (b,drop (ruleNArgs r) xs)
+    f (_:rs) = f rs
+
+
+preludeError = nameValue "Prelude" "error"
+ruleError = toAtom "Rule.error/EError"
+
+hasBuiltinRule TVr { tvrIdent = n } = n `Set.member` Set.fromList [preludeError]
+builtinRule TVr { tvrIdent = n } (ty:s:rs)
+    | n == preludeError, Just s' <- toString s  = do
+        mtick ruleError
+        return $ Just ((EError ("Prelude.error: " ++ s') ty),rs)
+builtinRule _ _ = return Nothing
hunk ./Main.hs 109
+    f n (ELam _ e) = let n' = n + 1 in n' `seq` f n' e
hunk ./Main.hs 111
-    f n (ELam _ e) = f (n + 1) e
hunk ./Main.hs 113
-idann ps i = return (props ps i)
-props ps i = case tvrName (TVr { tvrIdent = i }) of
-    Just n -> case Map.lookup n ps of
-        Just ps ->  Info.singleton (Properties $ Set.fromList ps)
-        Nothing ->  mempty
-    Nothing -> mempty
+idann rs ps i = return (props ps i `mappend` rules rs i) where
+    props ps i = case tvrName (tvr { tvrIdent = i }) of
+        Just n -> case Map.lookup n ps of
+            Just ps ->  Info.singleton (Properties $ Set.fromList ps)
+            Nothing ->  mempty
+        Nothing -> mempty
+    rules rs i = Info.maybeInsert (getARules rs i) Info.empty
hunk ./Main.hs 125
-    let Identity (ELetRec ds (ESort 0)) = annotate mempty (idann (hoProps ho) ) letann lamann (ELetRec (Map.elems $ hoEs ho) eStar)
+    let Identity (ELetRec ds (ESort 0)) = annotate mempty (idann (hoRules ho) (hoProps ho) ) letann lamann (ELetRec (Map.elems $ hoEs ho) eStar)
hunk ./Main.hs 163
-        nfo <- idann (hoProps ho') (tvrIdent v)
+        nfo <- idann (hoRules ho') (hoProps ho') (tvrIdent v)
hunk ./Main.hs 173
-        lc <- mangle False ("Annotate") (annotate annmap (idann (hoProps ho `mappend` hoProps ho')) letann (\_ -> return mempty)) lc
+        lc <- mangle False ("Annotate") (annotate annmap (idann (hoRules ho `mappend` hoRules ho') (hoProps ho `mappend` hoProps ho')) letann (\_ -> return mempty)) lc
hunk ./Main.hs 269
+
+    let ELetRec ds _ = lc in mapM_ (\t -> putStrLn (prettyE (EVar t) <+> show (tvrInfo t))) (fsts ds)