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
20 import Language.Core.Core
21 import Language.Core.Dependencies
22 import Language.Core.Overrides
23 import Language.Core.Prims
24 import Language.Core.Check
25 import Language.Core.Prep
26 import Language.Core.Interp
27 import Language.Core.ParsecParser
29 -- You may need to change this.
31 baseDir = "../../libraries/"
32 -- change to True to typecheck library files as well as reading type signatures
36 -- You shouldn't *need* to change anything below this line...
38 -- Code to check that the external and GHC printers print the same results
39 validateResults :: FilePath -> Module -> IO ()
40 validateResults origFile m = do
41 let genFile = origFile </> "parsed"
42 writeFile genFile (show m)
43 resultCode <- system $ "diff -u " ++ origFile ++ " " ++ genFile
44 putStrLn $ case resultCode of
45 ExitSuccess -> "Parse validated for " ++ origFile
46 ExitFailure 1 -> "Parse failed to validate for " ++ origFile
47 _ -> "Error diffing files: " ++ origFile ++ " " ++ genFile
48 ------------------------------------------------------------------------------
50 data Flag = Test | NoDeps
53 options :: [OptDescr Flag]
55 [Option ['t'] ["test"] (NoArg Test) "validate prettyprinted code",
56 Option ['n'] ["no-deps"] (NoArg NoDeps) "don't compute dependencies automatically"
59 process :: Bool -> (Check.Menv,[Module]) -> (FilePath, Module)
60 -> IO (Check.Menv,[Module])
61 process _ (senv,modules) p@(f,m) | isLib p && not typecheckLibs = do
62 -- if it's a library and we set typecheckLibs to False:
63 -- prep, but don't typecheck
65 return (senv, modules ++ [m'])
66 where isLib (fp,_) = baseDir `isPrefixOf` fp
67 process doTest (senv,modules) (f, m@(Module mn _ _)) = catch (do
68 when doTest $ validateResults f m
69 (case checkModule senv m of
71 do putStrLn $ "Check succeeded for " ++ show mn
73 case checkModule senv' m' of
75 do putStrLn "Recheck succeeded"
76 return (senv'',modules ++ [m'])
78 do putStrLn ("Recheck failed: " ++ s)
80 FailC s -> error ("Typechecking failed: " ++ s))) handler
82 putStrLn ("WARNING: we caught an exception " ++ show e
83 ++ " while processing " ++ f)
84 return (senv, modules)
86 prepM :: Check.Menv -> Module -> FilePath -> IO Module
88 let m' = prepModule senv' m
89 --writeFile (f </> ".prepped") (show m')
95 case getOpt Permute options args of
96 (opts, fnames@(_:_), _) ->
97 let doTest = Test `elem` opts
98 computeDeps = NoDeps `notElem` opts in
99 doOneProgram computeDeps doTest fnames
100 _ -> error "usage: ./Driver [filename]"
101 where doOneProgram :: Bool -> Bool -> [FilePath] -> IO ()
102 doOneProgram computeDeps doTest fns = do
103 putStrLn $ "========== Program " ++ (show fns) ++ " ============="
104 deps <- if computeDeps
107 else (liftM catMaybes) (mapM findModuleDirect fns)
108 putStrLn $ "deps = " ++ show (fst (unzip deps))
110 Note that we scan over the libraries twice:
111 first to gather together all type sigs, then to typecheck them
112 (the latter of which doesn't necessarily have to be done every time.)
113 This is a hack to avoid dealing with circular dependencies.
115 -- notice: scan over libraries *and* input modules first, not just libs
116 topEnv <- mkInitialEnv (snd (unzip deps))
117 (_,modules) <- foldM (process doTest) (topEnv,[]) deps
118 let succeeded = length modules
119 putStrLn ("Finished typechecking. Successfully checked "
121 overridden <- override modules
122 result <- evalProgram overridden
123 putStrLn ("Result = " ++ show result)
124 putStrLn "All done\n============================================="
126 mkInitialEnv :: [Module] -> IO Menv
127 mkInitialEnv libs = foldM mkTypeEnv initialEnv libs
129 mkTypeEnv :: Menv -> Module -> IO Menv
130 mkTypeEnv globalEnv m@(Module mn _ _) =
131 catch (return (envsModule globalEnv m)) handler
133 putStrLn ("WARNING: mkTypeEnv caught an exception " ++ show e
134 ++ " while processing " ++ show mn)
137 findModuleDirect :: FilePath -> IO (Maybe (FilePath, Module))
138 -- kludge to let us run "make libtest" --
139 -- this module (in the Cabal package) causes an uncaught exception
140 -- from Prelude.chr, which I haven't been able to track down
141 findModuleDirect fn | "PackageDescription.hcr" `isSuffixOf` fn = return Nothing
142 findModuleDirect fn = do
143 putStrLn $ "Finding " ++ show fn
146 Left err -> error (show err)
147 Right m -> return $ Just (fn,m)