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
13 import Prelude hiding (catch)
15 import System.Console.GetOpt
16 import System.Environment
18 import System.FilePath
30 -- You may need to change this.
32 baseDir = "../../libraries/"
33 -- change to True to typecheck library files as well as reading type signatures
37 -- You shouldn't *need* to change anything below this line...
39 -- Code to check that the external and GHC printers print the same results
40 validateResults :: FilePath -> Module -> IO ()
41 validateResults origFile m = do
42 let genFile = origFile </> "parsed"
43 writeFile genFile (show m)
44 resultCode <- system $ "diff -u " ++ origFile ++ " " ++ genFile
45 putStrLn $ case resultCode of
46 ExitSuccess -> "Parse validated for " ++ origFile
47 ExitFailure 1 -> "Parse failed to validate for " ++ origFile
48 _ -> "Error diffing files: " ++ origFile ++ " " ++ genFile
49 ------------------------------------------------------------------------------
51 data Flag = Test | NoDeps
54 options :: [OptDescr Flag]
56 [Option ['t'] ["test"] (NoArg Test) "validate prettyprinted code",
57 Option ['n'] ["no-deps"] (NoArg NoDeps) "don't compute dependencies automatically"
60 process :: Bool -> (Check.Menv,[Module]) -> (FilePath, Module)
61 -> IO (Check.Menv,[Module])
62 process _ (senv,modules) p@(f,m) | isLib p && not typecheckLibs = do
63 -- if it's a library and we set typecheckLibs to False:
64 -- prep, but don't typecheck
66 return (senv, modules ++ [m'])
67 where isLib (fp,_) = baseDir `isPrefixOf` fp
68 process doTest (senv,modules) (f, m@(Module mn _ _)) = catch (do
69 when doTest $ validateResults f m
70 (case checkModule senv m of
72 do putStrLn $ "Check succeeded for " ++ show mn
74 case checkModule senv' m' of
76 do putStrLn "Recheck succeeded"
77 return (senv'',modules ++ [m'])
79 do putStrLn ("Recheck failed: " ++ s)
81 FailC s -> error ("Typechecking failed: " ++ s))) handler
83 putStrLn ("WARNING: we caught an exception " ++ show e
84 ++ " while processing " ++ f)
85 return (senv, modules)
87 prepM :: Check.Menv -> Module -> FilePath -> IO Module
89 let m' = prepModule senv' m
90 --writeFile (f </> ".prepped") (show m')
96 case getOpt Permute options args of
97 (opts, fnames@(_:_), _) ->
98 let doTest = Test `elem` opts
99 computeDeps = NoDeps `notElem` opts in
100 doOneProgram computeDeps doTest fnames
101 _ -> error "usage: ./Driver [filename]"
102 where doOneProgram :: Bool -> Bool -> [FilePath] -> IO ()
103 doOneProgram computeDeps doTest fns = do
104 putStrLn $ "========== Program " ++ (show fns) ++ " ============="
105 deps <- if computeDeps
108 else (liftM catMaybes) (mapM findModuleDirect fns)
109 putStrLn $ "deps = " ++ show (fst (unzip deps))
111 Note that we scan over the libraries twice:
112 first to gather together all type sigs, then to typecheck them
113 (the latter of which doesn't necessarily have to be done every time.)
114 This is a hack to avoid dealing with circular dependencies.
116 -- notice: scan over libraries *and* input modules first, not just libs
117 topEnv <- mkInitialEnv (snd (unzip deps))
118 (_,modules) <- foldM (process doTest) (topEnv,[]) deps
119 let succeeded = length modules
120 putStrLn ("Finished typechecking. Successfully checked "
122 overridden <- override modules
123 result <- evalProgram overridden
124 putStrLn ("Result = " ++ show result)
125 putStrLn "All done\n============================================="
127 mkInitialEnv :: [Module] -> IO Menv
128 mkInitialEnv libs = foldM mkTypeEnv initialEnv libs
130 mkTypeEnv :: Menv -> Module -> IO Menv
131 mkTypeEnv globalEnv m@(Module mn _ _) =
132 catch (return (envsModule globalEnv m)) handler
134 putStrLn ("WARNING: mkTypeEnv caught an exception " ++ show e
135 ++ " while processing " ++ show mn)
138 findModuleDirect :: FilePath -> IO (Maybe (FilePath, Module))
139 -- kludge to let us run "make libtest" --
140 -- this module (in the Cabal package) causes an uncaught exception
141 -- from Prelude.chr, which I haven't been able to track down
142 findModuleDirect fn | "PackageDescription.hcr" `isSuffixOf` fn = return Nothing
143 findModuleDirect fn = do
144 putStrLn $ "Finding " ++ show fn
147 Left err -> error (show err)
148 Right m -> return $ Just (fn,m)