2 {- A simple driver that loads, typechecks, prepares, re-typechecks, and interprets the
3 GHC standard Prelude modules and an application module called Main.
5 Note that, if compiled under GHC, this requires a very large heap to run!
8 import Control.Exception
12 import Prelude hiding (catch)
14 import System.Console.GetOpt
15 import System.Environment
17 import System.FilePath
19 import Language.Core.Core
20 import Language.Core.Dependencies
21 import Language.Core.Overrides
22 import Language.Core.Prims
23 import Language.Core.Check
24 import Language.Core.Prep
25 import Language.Core.Interp
26 import Language.Core.ParsecParser
28 -- You may need to change this.
30 baseDir = "../../libraries/"
31 -- change to True to typecheck library files as well as reading type signatures
35 -- You shouldn't *need* to change anything below this line...
37 -- Code to check that the external and GHC printers print the same results
38 validateResults :: FilePath -> Module -> IO ()
39 validateResults origFile m = do
40 let genFile = origFile </> "parsed"
41 writeFile genFile (show m)
42 resultCode <- system $ "diff -u " ++ origFile ++ " " ++ genFile
43 putStrLn $ case resultCode of
44 ExitSuccess -> "Parse validated for " ++ origFile
45 ExitFailure 1 -> "Parse failed to validate for " ++ origFile
46 _ -> "Error diffing files: " ++ origFile ++ " " ++ genFile
47 ------------------------------------------------------------------------------
49 data Flag = Test | NoDeps
52 options :: [OptDescr Flag]
54 [Option ['t'] ["test"] (NoArg Test) "validate prettyprinted code",
55 Option ['n'] ["no-deps"] (NoArg NoDeps) "don't compute dependencies automatically"
58 process :: Bool -> (Menv,[Module]) -> (FilePath, Module)
60 process _ (senv,modules) p@(f,m) | isLib p && not typecheckLibs = do
61 -- if it's a library and we set typecheckLibs to False:
62 -- prep, but don't typecheck
64 return (senv, modules ++ [m'])
65 where isLib (fp,_) = baseDir `isPrefixOf` fp
66 process doTest (senv,modules) (f, m@(Module mn _ _)) = catch (do
67 when doTest $ validateResults f m
68 (case checkModule senv m of
70 do putStrLn $ "Check succeeded for " ++ show mn
72 case checkModule senv' m' of
74 do putStrLn "Recheck succeeded"
75 return (senv'',modules ++ [m'])
77 do putStrLn ("Recheck failed: " ++ s)
79 FailC s -> error ("Typechecking failed: " ++ s))) handler
81 putStrLn ("WARNING: we caught an exception " ++ show e
82 ++ " while processing " ++ f)
83 return (senv, modules)
85 prepM :: Menv -> Module -> FilePath -> IO Module
87 let m' = prepModule senv' m
88 --writeFile (f </> ".prepped") (show m')
94 case getOpt Permute options args of
95 (opts, fnames@(_:_), _) ->
96 let doTest = Test `elem` opts
97 computeDeps = NoDeps `notElem` opts in
98 doOneProgram computeDeps doTest fnames
99 _ -> error "usage: ./Driver [filename]"
100 where doOneProgram :: Bool -> Bool -> [FilePath] -> IO ()
101 doOneProgram computeDeps doTest fns = do
102 putStrLn $ "========== Program " ++ (show fns) ++ " ============="
103 deps <- if computeDeps
106 else (liftM catMaybes) (mapM findModuleDirect fns)
107 putStrLn $ "deps = " ++ show (fst (unzip deps))
109 Note that we scan over the libraries twice:
110 first to gather together all type sigs, then to typecheck them
111 (the latter of which doesn't necessarily have to be done every time.)
112 This is a hack to avoid dealing with circular dependencies.
114 -- notice: scan over libraries *and* input modules first, not just libs
115 topEnv <- mkInitialEnv (snd (unzip deps))
116 (_,modules) <- foldM (process doTest) (topEnv,[]) deps
117 let succeeded = length modules
118 putStrLn ("Finished typechecking. Successfully checked "
120 overridden <- override modules
121 result <- evalProgram overridden
122 putStrLn ("Result = " ++ show result)
123 putStrLn "All done\n============================================="
125 mkInitialEnv :: [Module] -> IO Menv
126 mkInitialEnv libs = foldM mkTypeEnv initialEnv libs
128 mkTypeEnv :: Menv -> Module -> IO Menv
129 mkTypeEnv globalEnv m@(Module mn _ _) =
130 catch (return (envsModule globalEnv m)) handler
132 putStrLn ("WARNING: mkTypeEnv caught an exception " ++ show e
133 ++ " while processing " ++ show mn)
136 findModuleDirect :: FilePath -> IO (Maybe (FilePath, Module))
137 -- kludge to let us run "make libtest" --
138 -- this module (in the Cabal package) causes an uncaught exception
139 -- from Prelude.chr, which I haven't been able to track down
140 findModuleDirect fn | "PackageDescription.hcr" `isSuffixOf` fn = return Nothing
141 findModuleDirect fn = do
142 putStrLn $ "Finding " ++ show fn
145 Left err -> error (show err)
146 Right m -> return $ Just (fn,m)