[create a program transformer that takes care of typechecking and printing appropriate error messages
John Meacham <john@repetae.net>**20060323005913] hunk ./E/SSimplify.hs 51
+newtype FreeVarSet = FreeVarSet (Set.Set Id)
+    deriving(Typeable,Show,Monoid)
hunk ./E/Traverse.hs 217
+    g Unknown = return Unknown
hunk ./Main.hs 146
+barendregtProgram prog = programSetDs ds' prog where
+    Identity (ELetRec ds' Unknown) = renameTraverse' (ELetRec (programDs prog) Unknown)
+
+
+barendregtProg prog = do
+    transformProgram "Barendregt" (dump FD.Pass) (return . barendregtProgram) prog
+
hunk ./Main.hs 216
-    sequence_ [lintCheckE fullDataTable v e | (_,v,e) <- ds ]
+    sequence_ [lintCheckE onerrNone fullDataTable v e | (_,v,e) <- ds ]
hunk ./Main.hs 248
-    prog <- return $ programPruneUnreachable prog
-
-    lintCheckProgram prog
+    prog <- programPrune prog
hunk ./Main.hs 272
+        when (dump FD.Lambdacube || dump FD.Pass) $ putErrLn ("----\n" ++ pprint names)
hunk ./Main.hs 287
-        lintCheckProgram mprog
+
+        lintCheckProgram onerrNone mprog
+        mprog <- barendregtProg mprog
hunk ./Main.hs 293
-            lc <- mangle (return ()) False ("Barendregt: " ++ pprint v) (return . barendregt) lc
hunk ./Main.hs 295
-        (mprog,_) <- typeAnalyze mprog
-
-        lintCheckProgram mprog
-        mprog <- floatOutward mprog
-        lintCheckProgram mprog
+        lintCheckProgram onerrNone mprog
+        mprog <- barendregtProg mprog
+        mprog <- transformProgram "typeAnalyze" (dump FD.Pass) (fmap fst . typeAnalyze) mprog
+        mprog <- transformProgram "floatOutward" (dump FD.Pass) floatOutward mprog
+        mprog <- barendregtProg mprog
hunk ./Main.hs 308
-        lintCheckProgram mprog
+        lintCheckProgram onerrNone mprog
hunk ./Main.hs 311
-            lc <- mangle (return ()) False ("Barendregt: " ++ pprint v) (return . barendregt) lc
hunk ./Main.hs 313
-        lintCheckProgram mprog
+        lintCheckProgram onerrNone mprog
+        mprog <- barendregtProg mprog
hunk ./Main.hs 323
-    lintCheckProgram prog
+    lintCheckProgram onerrNone prog
hunk ./Main.hs 329
-    lintCheckProgram prog
+    lintCheckProgram onerrNone prog
hunk ./Main.hs 349
-            lintCheckE fullDataTable v lc
+            lintCheckE onerrNone fullDataTable v lc
hunk ./Main.hs 354
-            lintCheckE fullDataTable v lc
+            lintCheckE onerrNone fullDataTable v lc
hunk ./Main.hs 359
-            lintCheckE fullDataTable v lc
+            lintCheckE onerrNone fullDataTable v lc
hunk ./Main.hs 363
-            lintCheckE fullDataTable v lc
+            lintCheckE onerrNone fullDataTable v lc
hunk ./Main.hs 379
-        sequence_ [lintCheckE fullDataTable v e | (v,e) <- cds ]
+        sequence_ [lintCheckE onerrNone fullDataTable v e | (v,e) <- cds ]
hunk ./Main.hs 381
-        sequence_ [lintCheckE fullDataTable v e | (v,e) <- cds ]
+        sequence_ [lintCheckE onerrNone fullDataTable v e | (v,e) <- cds ]
hunk ./Main.hs 417
-    prog <- return $ programPruneUnreachable prog
+    prog <- programPrune prog
hunk ./Main.hs 424
-        prog <- if null $ programDs prog then return prog else do
-            ne <- (return . barendregt) (programE prog)
-            return $ programSetE ne prog
+        prog <- barendregtProg prog
hunk ./Main.hs 426
+        progress "Post typeanalyis/etaexpansion pass"
hunk ./Main.hs 430
-        progress "Post typeanalyis/etaexpansion pass"
hunk ./Main.hs 434
-    prog <- return $ programPruneUnreachable prog
-    lintCheckProgram prog
+    prog <- programPrune prog
hunk ./Main.hs 445
+programPrune :: Program -> IO Program
+programPrune prog = transformProgram "Prune Unreachable" (dump FD.Pass) (return . programPruneUnreachable) prog
hunk ./Main.hs 490
-    prog <- return $ programPruneUnreachable prog
-
-    lintCheckProgram prog
+    prog <- programPrune prog
hunk ./Main.hs 499
-    lintCheckProgram prog
+    lintCheckProgram onerrNone prog
hunk ./Main.hs 515
-    prog <- return $ programPruneUnreachable prog
-
-    lintCheckProgram prog
+    prog <- programPrune prog
hunk ./Main.hs 521
-    lintCheckProgram prog
-
hunk ./Main.hs 525
-    ne <- mangle dataTable (return ()) True "Barendregt" (return . barendregt) (programE prog)
-    prog <- return $ programSetE ne prog
-
-
+    prog <- barendregtProg prog
hunk ./Main.hs 542
-    lc <- mangle dataTable (return ()) True "Barendregt" (return . barendregt) lc
hunk ./Main.hs 543
+    prog <- barendregtProg prog
hunk ./Main.hs 553
-    lc <- mangle dataTable (return ()) True "Barendregt" (return . barendregt) lc
hunk ./Main.hs 554
+    prog <- barendregtProg prog
hunk ./Main.hs 571
-    prog <- if null $ programDs prog then return prog else do
-        ne <- (return . barendregt) (programE prog)
-        return $ programSetE ne prog
+    prog <- barendregtProg prog
hunk ./Main.hs 575
-    lintCheckProgram prog
hunk ./Main.hs 576
-    prog <- lambdaLift finalStats prog
-    lintCheckProgram prog
+    prog <- transformProgram "lambda lift" (dump FD.Progress) (lambdaLift finalStats) prog
hunk ./Main.hs 687
+
+-- all transformation routines assume they are being passed a correct program, and only check the output
+
+transformProgram ::
+    String                      -- ^ name of pass
+    -> Bool                     -- ^ whether to dump progress
+    -> (Program -> IO Program)  -- ^ what to run
+    -> Program
+    -> IO Program
+
+transformProgram name dodump f prog = do
+    when dodump $ putErrLn $ "-- " ++ name
+    let istat = progStats prog
+    prog' <- f prog { progStats = mempty }
+    let estat = progStats prog'
+        onerr = do
+            putErrLn $ "\n>>> Before " ++ name
+            printProgram prog
+            Stats.printStat name estat
+            putErrLn $ "\n>>> After " ++ name
+    lintCheckProgram onerr prog'
+    return prog' { progStats = istat `mappend` estat, progPasses = name:progPasses prog' }
+
hunk ./Main.hs 809
-lintCheckE dataTable tvr e | flint = case inferType dataTable [] e of
+onerrNone = return ()
+onerrProg prog = putErrLn ">>> Before" >> printProgram prog
+
+lintCheckE onerr dataTable tvr e | flint = case inferType dataTable [] e of
hunk ./Main.hs 814
+        onerr
+        putErrLn ">>> Type Error"
hunk ./Main.hs 820
-lintCheckE _ _ _ = return ()
+lintCheckE _ _ _ _ = return ()
hunk ./Main.hs 822
-lintCheckProgram prog | flint = do
-    let f (tvr,e) = lintCheckE (progDataTable prog) tvr e
+lintCheckProgram onerr prog | flint = do
+    let f (tvr,e) = lintCheckE onerr (progDataTable prog) tvr e
hunk ./Main.hs 825
+        onerr
+        putErrLn ">>> Repeated top level decls"
hunk ./Main.hs 828
-        putErrLn "program has repeated toplevel definitions"
+        putErrLn ">>> program has repeated toplevel definitions"
hunk ./Main.hs 835
-        putErrLn ("Unaccounted for free variables: " ++ render (pprint $ Set.toList $ unaccounted))
+        onerr
+        putErrLn (">>> Unaccounted for free variables: " ++ render (pprint $ Set.toList $ unaccounted))
hunk ./Main.hs 838
-lintCheckProgram _ = return ()
+lintCheckProgram _ _ = return ()
+
+
+
+