3 {- A simple driver that loads, typechecks, prepares, re-typechecks, and interprets the
4 GHC standard Prelude modules and an application module called Main.
6 Note that, if compiled under GHC, this requires a very large heap to run!
9 import Control.Exception
12 import Prelude hiding (catch)
14 import System.Environment
16 import System.FilePath
25 -- You may need to change this.
27 baseDir = "../../libraries/"
28 -- change to True to typecheck library files as well as reading type signatures
32 -- You shouldn't *need* to change anything below this line...
34 -- Code to check that the external and GHC printers print the same results
37 validateResults :: FilePath -> Module -> IO ()
38 validateResults origFile m = do
39 let genFile = origFile </> "parsed"
40 writeFile genFile (show m)
41 resultCode <- system $ "diff -u " ++ origFile ++ " " ++ genFile
42 putStrLn $ case resultCode of
43 ExitSuccess -> "Parse validated for " ++ origFile
44 ExitFailure 1 -> "Parse failed to validate for " ++ origFile
45 _ -> "Error diffing files: " ++ origFile ++ " " ++ genFile
46 ------------------------------------------------------------------------------
48 process :: Bool -> (Check.Menv,[Module]) -> (FilePath, Module)
49 -> IO (Check.Menv,[Module])
50 process _ (senv,modules) p@(f,m) | isLib p && not typecheckLibs = do
51 -- if it's a library and we set typecheckLibs to False:
52 -- prep, but don't typecheck
54 return (senv, modules ++ [m'])
55 where isLib (fp,_) = baseDir `isPrefixOf` fp
56 process doTest (senv,modules) (f, m@(Module mn _ _)) = catch (do
57 when doTest $ validateResults f m
58 (case checkModule senv m of
60 do putStrLn $ "Check succeeded for " ++ show mn
62 case checkModule senv' m' of
64 do putStrLn "Recheck succeeded"
65 return (senv'',modules ++ [m'])
67 do putStrLn ("Recheck failed: " ++ s)
69 FailC s -> error ("Typechecking failed: " ++ s))) handler
71 putStrLn ("WARNING: we caught an exception " ++ show e
72 ++ " while processing " ++ f)
73 return (senv, modules)
75 prepM :: Check.Menv -> Module -> FilePath -> IO Module
77 let m' = prepModule senv' m
78 --writeFile (f </> ".prepped") (show m')
84 let (doTest, fnames) =
86 (f:rest) | f == testFlag -> (True,rest)
87 rest@(_:_) -> (False,rest)
88 _ -> error "usage: ./Driver [filename]"
89 doOneProgram doTest fnames
90 where doOneProgram :: Bool -> [FilePath] -> IO ()
91 doOneProgram doTest fns = do
92 putStrLn $ "========== Program " ++ (show fns) ++ " ================"
93 deps <- getDependencies fns
94 -- putStrLn $ "deps = " ++ show (fst (unzip deps))
96 Note that we scan over the libraries twice:
97 first to gather together all type sigs, then to typecheck them
98 (the latter of which doesn't necessarily have to be done every time.)
99 This is a hack to avoid dealing with circular dependencies.
101 -- notice: scan over libraries *and* input modules first, not just libs
102 topEnv <- mkInitialEnv (snd (unzip deps))
103 (_,modules) <- foldM (process doTest) (topEnv,[]) deps
104 let succeeded = length modules
105 putStrLn ("Finished typechecking. Successfully checked "
107 result <- evalProgram modules
108 putStrLn ("Result = " ++ show result)
109 putStrLn "All done\n============================================="
111 mkInitialEnv :: [Module] -> IO Menv
112 mkInitialEnv libs = foldM mkTypeEnv initialEnv libs
114 mkTypeEnv :: Menv -> Module -> IO Menv
115 mkTypeEnv globalEnv m@(Module mn _ _) =
116 catch (return (envsModule globalEnv m)) handler
118 putStrLn ("WARNING: mkTypeEnv caught an exception " ++ show e
119 ++ " while processing " ++ show mn)