[move E linting code to E.Lint, clean up Main in various other ways.
John Meacham <john@repetae.net>**20090709023959
 Ignore-this: 344187ed208de6eaaf0a25f4af3c2a29
] addfile ./E/Lint.hs
hunk ./E/Lint.hs 1
+module E.Lint where
+
+import Control.Exception
+import Control.Monad
+import Control.Monad.Trans
+import qualified Data.Set as Set
+import Data.List as List
+import Data.Maybe
+import Support.Compat
+
+
+import Stats
+import Name.Id
+import Doc.DocLike
+import Doc.PPrint
+import Doc.Pretty
+import E.E
+import E.Show
+import E.Traverse
+import E.TypeCheck
+import E.Program
+import Util.SetLike as S
+import Util.Gen
+import Data.Monoid
+import Support.FreeVars
+import Support.Transform
+import Options
+import qualified FlagDump as FD
+import qualified IO
+
+
+-- all transformation routines assume they are being passed a correct program, and only check the output
+
+transformProgram :: MonadIO m => TransformParms Program -> Program -> m Program
+
+transformProgram TransformParms { transformIterate = IterateMax n } prog | n <= 0 = return prog
+transformProgram TransformParms { transformIterate = IterateExactly n } prog | n <= 0 = return prog
+transformProgram tp prog = liftIO $ do
+    let dodump = transformDumpProgress tp
+        name = transformCategory tp ++ pname (transformPass tp) ++ pname (transformName tp)
+        scname = transformCategory tp ++ pname (transformPass tp)
+        pname "" = ""
+        pname xs = '-':xs
+        iterate = transformIterate tp
+    when dodump $ putErrLn $ "-- " ++ name
+    when (dodump && dump FD.CorePass) $ printProgram prog
+    wdump FD.ESize $ printESize ("Before "++name) prog
+    let istat = progStats prog
+    let ferr e = do
+        putErrLn $ "\n>>> Exception thrown"
+        putErrLn $ "\n>>> Before " ++ name
+        printProgram prog
+        putErrLn $ "\n>>>"
+        putErrLn (show (e::SomeException))
+        maybeDie
+        return prog
+    prog' <- Control.Exception.catch (transformOperation tp prog { progStats = mempty }) ferr
+    let estat = progStats prog'
+        onerr = do
+            putErrLn $ "\n>>> Before " ++ name
+            printProgram prog
+            Stats.printStat name estat
+            putErrLn $ "\n>>> After " ++ name
+    if transformSkipNoStats tp && estat == mempty then do
+        when dodump $ putErrLn "program not changed"
+        return prog
+     else do
+    when (dodump && dump FD.CoreSteps && (not $ Stats.null estat)) $ Stats.printLStat (optStatLevel options) name estat
+    when verbose $ do
+        Stats.tick Stats.theStats scname
+        Stats.tickStat Stats.theStats (Stats.prependStat scname estat)
+    wdump FD.ESize $ printESize ("After  "++name) prog'
+    lintCheckProgram onerr prog'
+    if doIterate iterate (not $ Stats.null estat) then transformProgram tp { transformIterate = iterateStep iterate } prog' { progStats = istat `mappend` estat } else
+        return prog' { progStats = istat `mappend` estat, progPasses = name:progPasses prog' }
+
+maybeDie = case optKeepGoing options of
+    True -> return ()
+    False -> putErrDie "Internal Error"
+
+onerrNone :: IO ()
+onerrNone = return ()
+
+lintCheckE onerr dataTable tvr e | flint = case inferType dataTable [] e of
+    Left ss -> do
+        onerr
+        putErrLn ">>> Type Error"
+        putErrLn  ( render $ hang 4 (pprint tvr <+> equals <+> pprint e))
+        putErrLn $ "\n>>> internal error:\n" ++ unlines (intersperse "----" $ tail ss)
+        maybeDie
+    Right v -> return ()
+lintCheckE _ _ _ _ = return ()
+
+lintCheckProgram onerr prog | flint = do
+    when (hasRepeatUnder fst (programDs prog)) $ do
+        onerr
+        let repeats = [ x | x@(_:_:_) <- List.group $ sort (map fst (programDs prog))]
+        putErrLn $ ">>> Repeated top level decls: " ++ pprint repeats
+        printProgram prog
+        putErrLn $ ">>> program has repeated toplevel definitions" ++ pprint repeats
+        maybeDie
+    let f (tvr@TVr { tvrIdent = n },e) | isNothing $ fromId n = do
+            onerr
+            putErrLn $ ">>> non-unique name at top level: " ++ pprint tvr
+            printProgram prog
+            putErrLn $ ">>> non-unique name at top level: " ++ pprint tvr
+            maybeDie
+        f (tvr,e) = do
+            case scopeCheck False mempty e of
+                Left s -> do
+                    onerr
+                    putErrLn $ ">>> scopecheck failed in " ++ pprint tvr ++ " " ++ s
+                    printProgram prog
+                    putErrLn $ ">>> scopecheck failed in " ++ pprint tvr ++ " " ++ s
+                    maybeDie
+                Right () -> return ()
+            lintCheckE onerr (progDataTable prog) tvr e
+    mapM_ f (programDs prog)
+    let ids = progExternalNames prog `mappend` fromList (map tvrIdent $ fsts (programDs prog)) `mappend` progSeasoning prog
+        fvs = Set.fromList $ melems (freeVars $ snds $ programDs prog :: IdMap TVr)
+        unaccounted = Set.filter (not . (`member` ids) . tvrIdent) fvs
+    unless (Set.null unaccounted) $ do
+        onerr
+        putErrLn ("\n>>> Unaccounted for free variables: " ++ render (pprint $ Set.toList $ unaccounted))
+        printProgram prog
+        putErrLn (">>> Unaccounted for free variables: " ++ render (pprint $ Set.toList $ unaccounted))
+        --putErrLn (show ids)
+        maybeDie
+lintCheckProgram _ _ = return ()
+
+
+dumpCore pname prog = do
+    let fn = optOutName options ++ "_" ++ pname ++ ".jhc_core"
+    putErrLn $ "Writing: " ++ fn
+    h <- IO.openFile fn IO.WriteMode
+    (argstring,sversion) <- getArgString
+    IO.hPutStrLn h $ unlines [ "-- " ++ argstring,"-- " ++ sversion,""]
+    hPrintProgram h prog
+    IO.hClose h
+    wdump FD.Core $ do
+        putErrLn $ "v-- " ++ pname ++ " Core"
+        printProgram prog
+        putErrLn $ "^-- " ++ pname ++ " Core"
+
+
+printESize :: String -> Program -> IO ()
+printESize str prog = putErrLn $ str ++ " program e-size: " ++ show (eSize (programE prog))
hunk ./Interactive.hs 1
-module Interactive(Interactive.interact) where
+module Interactive(Interactive.interact, isInteractive) where
hunk ./Interactive.hs 3
-import Control.Monad.Reader
+import Control.Exception as CE
hunk ./Interactive.hs 5
+import Control.Monad.Reader
hunk ./Interactive.hs 7
-import Control.Exception as CE
hunk ./Interactive.hs 9
-import List(sort)
+import List(sort,isPrefixOf)
hunk ./Interactive.hs 12
+import System
+import Text.Regex
hunk ./Interactive.hs 16
-import Text.Regex
---import Text.Regex.Posix(regcomp,regExtended)
hunk ./Interactive.hs 256
+isInteractive :: IO Bool
+isInteractive = do
+    pn <- System.getProgName
+    return $ (optMode options == Interactive)
+          || "ichj" `isPrefixOf` reverse pn
+          || not (null $ optStmts options)
hunk ./Main.hs 11
-import qualified List(group,union)
hunk ./Main.hs 12
+import qualified Data.List as L
hunk ./Main.hs 14
+import Doc.PPrint
hunk ./Main.hs 18
-import Doc.DocLike
-import Doc.PPrint
-import Doc.Pretty
hunk ./Main.hs 22
+import E.Lint
hunk ./Main.hs 30
-import E.Show hiding(render)
hunk ./Main.hs 55
-import Name.Names
-import Name.VConsts
hunk ./Main.hs 59
-import Support.Compat
hunk ./Main.hs 116
-    int <- isInteractive
+    int <- Interactive.isInteractive
hunk ./Main.hs 134
---barendregtProg prog = transformProgram transBarendregt prog
-barendregtProg prog = return prog
-
-transBarendregt = transformParms {
-        transformCategory = "Barendregt",
-        transformIterate = DontIterate,
-        transformDumpProgress = corePass,
-        transformOperation =  evaluate . barendregtProgram
-        } where
-    barendregtProgram prog | null $ progCombinators prog = prog
-    barendregtProgram prog = programSetDs ds' prog where
-        (ELetRec ds' Unknown,_) = renameE mempty mempty (ELetRec (programDs prog) Unknown)
-
hunk ./Main.hs 163
-            f rs = List.union  rs [ x | x <- nrules, ruleHead x == combHead comb]
+            f rs = L.union  rs [ x | x <- nrules, ruleHead x == combHead comb]
hunk ./Main.hs 251
-            Just rs -> combRules_u (map ruleUpdate . List.union rs) c
+            Just rs -> combRules_u (map ruleUpdate . L.union rs) c
hunk ./Main.hs 302
-        mprog <- barendregtProg mprog
hunk ./Main.hs 316
-        mprog <- barendregtProg mprog
hunk ./Main.hs 322
-        mprog <- barendregtProg mprog
hunk ./Main.hs 337
-    prog <- barendregtProg prog { progStats = mempty }
-    prog <- etaExpandProg "Init-Big-One" prog
+    prog <- etaExpandProg "Init-Big-One" prog { progStats = mempty }
hunk ./Main.hs 362
-        mprog <- barendregtProg mprog
hunk ./Main.hs 392
-    prog <- barendregtProg prog { progStats = mempty }
-    prog <- evalStateT (programMapProgGroups mempty optWW prog) (SS.so_boundVars sopt)
+    prog <- evalStateT (programMapProgGroups mempty optWW prog { progStats = mempty }) (SS.so_boundVars sopt)
hunk ./Main.hs 445
-isInteractive :: IO Bool
-isInteractive = do
-    pn <- System.getProgName
-    return $ (optMode options == Interactive)
-          || "ichj" `isPrefixOf` reverse pn
-          || not (null $ optStmts options)
-
hunk ./Main.hs 472
-    int <- isInteractive
+    int <- Interactive.isInteractive
hunk ./Main.hs 491
-    prog <- barendregtProg prog
hunk ./Main.hs 528
-        prog <- barendregtProg prog
hunk ./Main.hs 536
-    prog <- barendregtProg prog
hunk ./Main.hs 539
-    prog <- barendregtProg prog
hunk ./Main.hs 542
-    prog <- barendregtProg prog
hunk ./Main.hs 545
-    prog <- barendregtProg prog
hunk ./Main.hs 546
-    prog <- barendregtProg prog
hunk ./Main.hs 555
-    prog <- barendregtProg prog
hunk ./Main.hs 573
-    prog <- barendregtProg prog
hunk ./Main.hs 763
-dumpCore pname prog = do
-    let fn = optOutName options ++ "_" ++ pname ++ ".jhc_core"
-    putErrLn $ "Writing: " ++ fn
-    h <- IO.openFile fn IO.WriteMode
-    (argstring,sversion) <- getArgString
-    IO.hPutStrLn h $ unlines [ "-- " ++ argstring,"-- " ++ sversion,""]
-    hPrintProgram h prog
-    IO.hClose h
-    wdump FD.Core $ do
-        putErrLn $ "v-- " ++ pname ++ " Core"
-        printProgram prog
-        putErrLn $ "^-- " ++ pname ++ " Core"
hunk ./Main.hs 799
--- all transformation routines assume they are being passed a correct program, and only check the output
-
-
-
-
-
-transformProgram :: MonadIO m => TransformParms Program -> Program -> m Program
-
-transformProgram TransformParms { transformIterate = IterateMax n } prog | n <= 0 = return prog
-transformProgram TransformParms { transformIterate = IterateExactly n } prog | n <= 0 = return prog
-transformProgram tp prog = liftIO $ do
-    let dodump = transformDumpProgress tp
-        name = transformCategory tp ++ pname (transformPass tp) ++ pname (transformName tp)
-        scname = transformCategory tp ++ pname (transformPass tp)
-        pname "" = ""
-        pname xs = '-':xs
-        iterate = transformIterate tp
-    when dodump $ putErrLn $ "-- " ++ name
-    when (dodump && corePass) $ printProgram prog
-    wdump FD.ESize $ printESize ("Before "++name) prog
-    let istat = progStats prog
-    let ferr e = do
-        putErrLn $ "\n>>> Exception thrown"
-        putErrLn $ "\n>>> Before " ++ name
-        printProgram prog
-        putErrLn $ "\n>>>"
-        putErrLn (show (e::SomeException))
-        maybeDie
-        return prog
-    prog' <- Control.Exception.catch (transformOperation tp prog { progStats = mempty }) ferr
-    let estat = progStats prog'
-        onerr = do
-            putErrLn $ "\n>>> Before " ++ name
-            printProgram prog
-            Stats.printStat name estat
-            putErrLn $ "\n>>> After " ++ name
-    if transformSkipNoStats tp && estat == mempty then do
-        when dodump $ putErrLn "program not changed"
-        return prog
-     else do
-    when (dodump && dump FD.CoreSteps && (not $ Stats.null estat)) $ Stats.printLStat (optStatLevel options) name estat
-    when collectPassStats $ do
-        Stats.tick Stats.theStats scname
-        Stats.tickStat Stats.theStats (Stats.prependStat scname estat)
-    wdump FD.ESize $ printESize ("After  "++name) prog'
-    lintCheckProgram onerr prog'
-    if doIterate iterate (not $ Stats.null estat) then transformProgram tp { transformIterate = iterateStep iterate } prog' { progStats = istat `mappend` estat } else
-        return prog' { progStats = istat `mappend` estat, progPasses = name:progPasses prog' }
-
-maybeDie = case optKeepGoing options of
-    True -> return ()
-    False -> putErrDie "Internal Error"
-
-onerrNone :: IO ()
-onerrNone = return ()
-
-
-
-lintCheckE onerr dataTable tvr e | flint = case inferType dataTable [] e of
-    Left ss -> do
-        onerr
-        putErrLn ">>> Type Error"
-        putErrLn  ( render $ hang 4 (pprint tvr <+> equals <+> pprint e))
-        putErrLn $ "\n>>> internal error:\n" ++ unlines (intersperse "----" $ tail ss)
-        maybeDie
-    Right v -> return ()
-lintCheckE _ _ _ _ = return ()
-
-lintCheckProgram onerr prog | flint = do
-    when (hasRepeatUnder fst (programDs prog)) $ do
-        onerr
-        let repeats = [ x | x@(_:_:_) <- List.group $ sort (map fst (programDs prog))]
-        putErrLn $ ">>> Repeated top level decls: " ++ pprint repeats
-        printProgram prog
-        putErrLn $ ">>> program has repeated toplevel definitions" ++ pprint repeats
-        maybeDie
-    let f (tvr@TVr { tvrIdent = n },e) | isNothing $ fromId n = do
-            onerr
-            putErrLn $ ">>> non-unique name at top level: " ++ pprint tvr
-            printProgram prog
-            putErrLn $ ">>> non-unique name at top level: " ++ pprint tvr
-            maybeDie
-        f (tvr,e) = do
-            case scopeCheck False mempty e of
-                Left s -> do
-                    onerr
-                    putErrLn $ ">>> scopecheck failed in " ++ pprint tvr ++ " " ++ s
-                    printProgram prog
-                    putErrLn $ ">>> scopecheck failed in " ++ pprint tvr ++ " " ++ s
-                    maybeDie
-                Right () -> return ()
-            lintCheckE onerr (progDataTable prog) tvr e
-    mapM_ f (programDs prog)
-    let ids = progExternalNames prog `mappend` fromList (map tvrIdent $ fsts (programDs prog)) `mappend` progSeasoning prog
-        fvs = Set.fromList $ melems (freeVars $ snds $ programDs prog :: IdMap TVr)
-        unaccounted = Set.filter (not . (`member` ids) . tvrIdent) fvs
-    unless (Set.null unaccounted) $ do
-        onerr
-        putErrLn ("\n>>> Unaccounted for free variables: " ++ render (pprint $ Set.toList $ unaccounted))
-        printProgram prog
-        putErrLn (">>> Unaccounted for free variables: " ++ render (pprint $ Set.toList $ unaccounted))
-        --putErrLn (show ids)
-        maybeDie
-lintCheckProgram _ _ = return ()
-
-
hunk ./Main.hs 801
-printESize :: String -> Program -> IO ()
-printESize str prog = putErrLn $ str ++ " program e-size: " ++ show (eSize (programE prog))
hunk ./Makefile.am 41
-	Support/IniParse.hs
+	Support/IniParse.hs E/Lint.hs