[add more rules to library, add unique name for each rule, make sure they are applied in order within a module, add parsing of SPECIALIZE pragmas
John Meacham <john@repetae.net>**20060211170442] hunk ./E/FromHs.hs 186
-        valToPat' (ELit (LitCons x ts t)) = ELit $ LitCons x [ EVar (tVr ( j) (getType z)) | z <- ts | j <- [2,4 ..]]  t
-        valToPat' (EPi (TVr { tvrType =  a}) b)  = ELit $ LitCons tc_Arrow [ EVar (tVr ( j) (getType z)) | z <- [a,b] | j <- [2,4 ..]]  eStar
+        valToPat' (ELit (LitCons x ts t)) = ELit $ LitCons x [ EVar (tVr j (getType z)) | z <- ts | j <- [2,4 ..]]  t
+        valToPat' (EPi (TVr { tvrType =  a}) b)  = ELit $ LitCons tc_Arrow [ EVar (tVr j (getType z)) | z <- [a,b] | j <- [2,4 ..]]  eStar
hunk ./E/FromHs.hs 190
-        rule t = emptyRule { ruleHead = methodVar, ruleArgs = [valToPat' (tipe t)], ruleBody = body, ruleName = toAtom $ "Rule.{" ++ show name ++ "}"}  where
+        rule t = emptyRule { ruleHead = methodVar, ruleArgs = [valToPat' (tipe t)], ruleBinds = [ t | ~(EVar t) <- vs], ruleBody = body, ruleUniq = (Module (show name),0), ruleName = toAtom $ "Rule.{" ++ show name ++ "}"}  where
hunk ./E/Rules.hs 3
-    Rule(ruleHead,ruleBinds,ruleArgs,ruleBody,ruleName),
+    Rule(ruleHead,ruleBinds,ruleArgs,ruleBody,ruleUniq,ruleName),
hunk ./E/Rules.hs 61
+    ruleUniq :: (Module,Int),
hunk ./E/Rules.hs 77
-    ruleName = error "ruleName undefined"
+    ruleName = error "ruleName undefined",
+    ruleUniq = error "ruleUniq undefined"
hunk ./E/Rules.hs 141
-combineRules as bs = map head $ sortGroupUnder ruleName (as ++ bs)
+combineRules as bs = map head $ sortGroupUnder ruleUniq (as ++ bs)
hunk ./E/Rules.hs 179
-    | all (== r) rs = ARules (sortUnder ruleNArgs (snubUnder ruleName $ a ++ b))
+    | all (== r) rs = ARules (sortUnder (\r -> (ruleNArgs r,ruleUniq r)) (snubUnder ruleUniq $ a ++ b))
hunk ./E/Rules.hs 184
-
-
hunk ./E/Rules.hs 208
+    -> (Module,Int)  -- ^ a unique name for this rule
hunk ./E/Rules.hs 214
-makeRule name fvs head args body = fromRules [rule] where
-    rule = emptyRule {  ruleHead = head, ruleBinds = fvs, ruleArgs = args, ruleNArgs = length args, ruleBody = body, ruleName = toAtom $ "Rule.User." ++ name }
+makeRule name uniq fvs head args body = fromRules [rule] where
+    rule = emptyRule {
+        ruleHead = head,
+        ruleBinds = fvs,
+        ruleArgs = args,
+        ruleNArgs = length args,
+        ruleBody = body,
+        ruleUniq = uniq,
+        ruleName = toAtom $ "Rule.User." ++ name
+        }
hunk ./E/TypeCheck.hs 279
-match lup vs e1 e2 = liftM Seq.toList $ execWriterT (un e1 e2 () (0::Int)) where
+match lup vs = \e1 e2 -> liftM Seq.toList $ execWriterT (un e1 e2 () (0::Int)) where
hunk ./E/TypeCheck.hs 281
+
hunk ./E/TypeCheck.hs 285
-    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
hunk ./E/TypeCheck.hs 295
-    un a@EVar {} b mm c = fail $ "Expressions do not unify: " ++ show a ++ show b
+
+    un (EVar TVr { tvrIdent = i, tvrType =  t}) (EVar TVr {tvrIdent = j, tvrType =  u}) mm c | i == j = un t u mm c
+    un (EVar tvr@TVr { tvrIdent = i, tvrType = t}) b mm c
+        | i `Set.member` bvs = tell (Seq.single (tvr,b))
+        | otherwise = fail $ "Expressions do not unify: " ++ show tvr ++ show b
hunk ./E/TypeCheck.hs 301
+
hunk ./FrontEnd/HsParser.ly 59
+>       PRAGMASPECIALIZE { PragmaSpecialize $$ }
hunk ./FrontEnd/HsParser.ly 289
+>       | srcloc PRAGMASPECIALIZE var '::' type PRAGMAEND
+>                       { HsPragmaSpecialize { hsDeclSrcLoc = $1, hsDeclBool = $2, hsDeclName = $3, hsDeclType = $5 } }
hunk ./FrontEnd/HsSyn.hs 130
+    srcLoc HsPragmaSpecialize { hsDeclSrcLoc = sl } = sl
+    srcLoc HsPragmaRules { hsDeclSrcLoc = sl } = sl
hunk ./FrontEnd/HsSyn.hs 156
+         | HsPragmaSpecialize { hsDeclSrcLoc :: SrcLoc, hsDeclBool :: Bool, hsDeclName :: HsName, hsDeclType :: HsType }
hunk ./FrontEnd/Lexer.hs 44
+        | PragmaSpecialize Bool
hunk ./FrontEnd/Lexer.hs 586
-    ["SPECIALIZE", "SPECIALISE"],
hunk ./FrontEnd/Lexer.hs 592
-    (["RULES"],PragmaRules)
+    (["RULES"],PragmaRules),
+    (["SPECIALIZE", "SPECIALISE"],PragmaSpecialize False),
+    (["SUPERSPECIALIZE", "SUPERSPECIALISE"],PragmaSpecialize True)
hunk ./FrontEnd/Rename.hs 419
+renameHsDecl prules@HsPragmaSpecialize { hsDeclSrcLoc = srcLoc, hsDeclName = n, hsDeclType = t } subTable = do
+    setSrcLoc srcLoc
+    n <- renameAny n subTable
+    t <- renameAny t subTable
+    return prules {  hsDeclName = n, hsDeclType = t }
hunk ./FrontEnd/Rename.hs 533
+instance RenameAny HsName where
+    renameAny = renameHsName
+instance RenameAny HsType where
+    renameAny = renameHsType
+
hunk ./Main.hs 147
---annotateMethods ch rs ps = (Map.fromList [ (tvrIdent t, Just (EVar t)) | t <- ts ]) where
---    ts = [ let Identity x = idann rs ps (tvrIdent t) (tvrInfo t) in t { tvrInfo = x  } | t <-methodNames ch ]
hunk ./Main.hs 150
-    --putStrLn $ "Initial annotate: " ++ show (Map.keys $ hoModules ho)
-    --let imap = annotateMethods (hoClassHierarchy ho) (hoRules ho) (hoProps ho)
-    --let f (ds,used) (v,lc) = ((v,lc'):ds,used `mappend` used') where
-    --        (lc',used') = runRename used lc
-    --    (nds,allUsed) = foldl f ([],Set.empty) (Map.elems $ hoEs ho)
hunk ./Main.hs 151
-    --wdump FD.Rules $ printRules (hoRules ho)
hunk ./Main.hs 172
+    -- initial program
+    let prog = program {
+            progClassHierarchy = hoClassHierarchy allHo,
+            progDataTable = fullDataTable,
+            progModule = head (fsts $ tiDataModules tiData)
+            }
+
hunk ./Main.hs 189
-    let nrules = mconcat [ makeRule n vs head args e2 | (n,vs,e1,e2) <- rawRules, let (EVar head,args) = fromAp e1 ]
+    let nrules = mconcat [ makeRule n (progModule prog,i) vs head args e2 | (n,vs,e1,e2) <- rawRules, let (EVar head,args) = fromAp e1 | i <- [1..] ]
hunk ./Main.hs 194
-    let prog = program { progClassHierarchy = hoClassHierarchy allHo, progDataTable = fullDataTable }
-
hunk ./lib/Prelude.hs 936
-{-# 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 "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 #-}
hunk ./lib/Prelude.hs 939
-{-# 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 #-}
+{-# RULES "++/emptyr"     forall xs . xs ++ [] = xs #-}
+{-# 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 "++/tick1"      forall x xs ys . (x:xs) ++ ys = x:(xs ++ ys) #-}
+{-# RULES "++/tick0"      forall xs . [] ++ xs = xs #-}
+{-# 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 #-}
+{-# RULES "concat/[]"     concat [] = [] #-}
+{-# RULES "map/[]"        forall f . map f [] = [] #-}
+{-# RULES "concatMap/[]"  forall f . concatMap f [] = [] #-}
+{-# RULES "sequence/[]"   sequence [] = return [] #-}
+{-# RULES "sequence_/[]"  sequence_ [] = return () #-}
+{-# RULES "mapM/[]"       forall f . mapM f [] = return [] #-}
+{-# RULES "mapM_/[]"      forall f . mapM_ f [] = return () #-}
+{-# RULES "foldr/single"  forall k z x . foldr k z [x] = k x z #-}
+{-# RULES "foldr/nil"     forall k z . foldr k z [] = z #-}
+{-# RULES "foldr/id"      foldr (:) [] = \x -> x  #-}