[add begining of user specified RULES
John Meacham <john@repetae.net>**20060209082930] hunk ./E/FromHs.hs 11
+    convertRules,
hunk ./E/FromHs.hs 62
+concatMapM f xs = do
+    xs <- mapM f xs
+    return $ concat xs
+
hunk ./E/FromHs.hs 245
+convertRules ::  Monad m => ClassHierarchy -> Map.Map Name Scheme -> DataTable -> [HsDecl] -> m [(String,[TVr],E,E)]
+convertRules classHierarchy assumps dataTable hsDecls = concatMapM f hsDecls where
+    f pr@HsPragmaRules {} = do
+        let ce = convertE classHierarchy assumps dataTable (hsDeclSrcLoc pr)
+        e1 <- ce (hsDeclLeftExpr pr)
+        e2 <- ce (hsDeclRightExpr pr)
+        cs <- mapM ce [ HsVar v | v <- hsDeclFreeVars pr ]
+        return [(hsDeclString pr,[ v | ~(EVar v) <- cs],e1,e2)]
+    f _ = return []
+
+convertE :: Monad m => ClassHierarchy -> Map.Map Name Scheme -> DataTable -> SrcLoc -> HsExp -> m E
+convertE classHierarchy assumps dataTable srcLoc exp = do
+    [(_,_,e)] <- convertDecls classHierarchy assumps dataTable [HsPatBind srcLoc (HsPVar sillyName') (HsUnGuardedRhs exp) []]
+    return e
hunk ./E/FromHs.hs 260
+sillyName = toName Val ("Jhc@","silly")
+sillyName' = nameName sillyName
hunk ./E/FromHs.hs 314
+    cDecl (HsPatBind sl p (HsUnGuardedRhs exp) []) | (HsPVar n) <- simplifyHsPat p, n == sillyName' = let
+        in [(sillyName,tvr,cExpr exp)]
hunk ./FrontEnd/HsParser.ly 58
+>       PRAGMARULES { PragmaRules }
hunk ./FrontEnd/HsParser.ly 286
+>       | srcloc PRAGMARULES STRING mfreevars exp '=' exp PRAGMAEND
+>                       { HsPragmaRules { hsDeclSrcLoc = $1, hsDeclString = $3, hsDeclFreeVars = $4, hsDeclLeftExpr = $5, hsDeclRightExpr = $7 } }
hunk ./FrontEnd/HsParser.ly 290
+> mfreevars :: { [HsName] }
+>       : 'forall' vbinds '.' { $2 }
+>       | { [] }
+
+> vbinds :: { [HsName] }
+>       : vbinds var                  { $2 : $1 }
+>       | var                         { [$1] }
+
hunk ./FrontEnd/HsPretty.hs 259
+ppHsDecl prules@HsPragmaRules {} = text ("{-# RULES " ++ show (hsDeclString prules)) <+> text "forall" <+> vars <+> text "." $$ nest 4 rest $$ text "#-}" where
+    vars = hsep (map ppHsName $ hsDeclFreeVars prules)
+    rest = ppHsExp (hsDeclLeftExpr prules) <+> text "=" <+> ppHsExp (hsDeclRightExpr prules)
hunk ./FrontEnd/HsSyn.hs 153
+	 | HsPragmaRules { hsDeclSrcLoc :: SrcLoc, hsDeclString :: String, hsDeclFreeVars :: [HsName], hsDeclLeftExpr :: HsExp, hsDeclRightExpr :: HsExp }
hunk ./FrontEnd/Infix.hs 142
-    HsPatBind      srcloc pat rhs decls    -> HsPatBind srcloc (procPat infixMap pat) (processRhs infixMap rhs) $
-                                                          proc_decls decls
+    HsPatBind      srcloc pat rhs decls    -> HsPatBind srcloc (procPat infixMap pat) (processRhs infixMap rhs) $ proc_decls decls
+    prules@HsPragmaRules { hsDeclLeftExpr = e1, hsDeclRightExpr = e2} ->
+        prules { hsDeclLeftExpr = fst $ processExp infixMap e1, hsDeclRightExpr = fst $ processExp infixMap e2 }
hunk ./FrontEnd/Rename.hs 194
+{-# NOINLINE renameModule #-}
hunk ./FrontEnd/Rename.hs 218
+{-# NOINLINE renameStatement #-}
hunk ./FrontEnd/Rename.hs 406
-    -- can't do this as we might already have an import
hunk ./FrontEnd/Rename.hs 407
-    -- we really just want to qualify the names with the
-    -- current module
-    {-
-    modName <- getCurrentModule
-    let hsNames' = map (Utils.qualifyName modName) hsNames
-    -}
hunk ./FrontEnd/Rename.hs 412
+renameHsDecl prules@HsPragmaRules { hsDeclSrcLoc = srcLoc, hsDeclFreeVars = fvs, hsDeclLeftExpr = e1, hsDeclRightExpr = e2 } subTable = do
+    setSrcLoc srcLoc
+    subTable' <- updateSubTableWithHsNames subTable fvs
+    fvs' <- renameHsNames fvs subTable'
+    e1' <- renameHsExp e1 subTable'
+    e2' <- renameHsExp e2 subTable'
+    return prules {  hsDeclFreeVars = fvs', hsDeclLeftExpr = e1', hsDeclRightExpr = e2' }
hunk ./FrontEnd/TIMain.hs 24
+import Data.Monoid
hunk ./FrontEnd/TIMain.hs 415
-   = withContext (locMsg sloc "in the guarded alternative" $ render $ ppGAlt gAlt) $
-     do
+   = withContext (locMsg sloc "in the guarded alternative" $ render $ ppGAlt gAlt) $ do
hunk ./FrontEnd/TIMain.hs 423
+tiPragmaRules :: TypeEnv -> HsDecl -> TI TypeEnv
+tiPragmaRules env prule@HsPragmaRules { hsDeclFreeVars = vs, hsDeclLeftExpr = e1, hsDeclRightExpr = e2, hsDeclSrcLoc = sloc } =
+    withContext (locMsg sloc "in the RULES pragma" $ hsDeclString prule) ans where
+        ans = do
+            vs' <- mapM dv vs
+            let (envs,vs'') = unzip vs'
+                nenv = mconcat envs
+            (_,env1,t1) <- tiExpr (env `mappend` nenv) e1
+            (_,env2,t2) <- tiExpr (env `mappend` nenv) e2
+            unify t1 t2
+
+            return (nenv `mappend` env1 `mappend` env2)
+
+        dv n = do
+            v <- newTVar Star
+            return (Map.singleton (toName Val n) (toScheme v),v)
+
+
+
+
hunk ./FrontEnd/TIMain.hs 707
-tiProgram ::  Opt -> Module -> SigEnv -> KindEnv -> ClassHierarchy -> TypeEnv -> TypeEnv -> Program -> IO TypeEnv
-tiProgram opt modName sEnv kt h dconsEnv env bgs = runTI opt dconsEnv h kt sEnv modName $
+tiProgram ::  Opt -> Module -> SigEnv -> KindEnv -> ClassHierarchy -> TypeEnv -> TypeEnv -> Program -> [HsDecl] -> IO TypeEnv
+tiProgram opt modName sEnv kt h dconsEnv env bgs rules = runTI opt dconsEnv h kt sEnv modName $
hunk ./FrontEnd/TIMain.hs 711
+     envs <- mapM (tiPragmaRules (env `mappend` env1)) (filter isHsPragmaRules rules)
hunk ./FrontEnd/TIMain.hs 717
-            env1' <- flattenType env1
+            env1' <- flattenType (mconcat $ env1:envs)
hunk ./FrontEnd/TIMain.hs 755
-tiPat (HsPLit l)
-   = do
+tiPat (HsPLit l) = do
hunk ./FrontEnd/TIModule.hs 249
+                ds                             -- all decls
+
hunk ./Interactive.hs 212
+                []
hunk ./Main.hs 184
+    rs <- convertRules (hoClassHierarchy ho') allAssumps fullDataTable decls
+    flip mapM_ rs $ \ (n,vs,e1,e2) -> do
+        putStrLn n
+        print vs
+        printCheckName' fullDataTable tvr e1
+        printCheckName' fullDataTable tvr e2
+
hunk ./test/Primes.hs 12
+
+{-
+the_filter :: [Int] -> [Int]
+the_filter (n:ns) = f ns where
+    f [] = []
+    f (x:ns) | isdivs n x = (x:f ns)
+    f (_:ns) = f ns
+-}