1 {- A simple driver that loads, typechecks, prepares, re-typechecks, and interprets the
2 GHC standard Prelude modules and an application module called Main.
4 Note that, if compiled under GHC, this requires a very large heap to run!
7 import Control.Exception
11 import Prelude hiding (catch)
13 import System.Environment
15 import System.FilePath
26 -- You may need to change this.
27 baseDir = "../../libraries/"
28 -- change to True to typecheck library files as well as reading type signatures
31 -- You shouldn't *need* to change anything below this line...
32 libDir = map (baseDir ++)
34 -- Code to check that the external and GHC printers print the same results
37 validateResults :: FilePath -> FilePath -> IO ()
38 validateResults origFile genFile = do
39 resultCode <- system $ "diff -u " ++ origFile ++ " " ++ genFile
40 putStrLn $ case resultCode of
41 ExitSuccess -> "Parse validated for " ++ origFile
42 ExitFailure 1 -> "Parse failed to validate for " ++ origFile
43 _ -> "Error diffing files: " ++ origFile ++ " " ++ genFile
44 ------------------------------------------------------------------------------
46 process :: Bool -> (Check.Menv,[Module]) -> FilePath
47 -> IO (Check.Menv,[Module])
48 process doTest (senv,modules) f = catch
49 (do putStrLn ("Processing " ++ f)
50 resultOrErr <- parseCore f
52 Right m@(Module mn _ _) -> do
53 putStrLn "Parse succeeded"
54 let outF = f ++ ".parsed"
55 writeFile outF (show m)
56 when doTest $ (validateResults f outF)
57 case checkModule senv m of
59 do putStrLn $ "Check succeeded for " ++ show mn
60 let m' = prepModule senv' m
61 let (dir,fname) = splitFileName f
62 let preppedFile = dir </> (fname ++ ".prepped")
63 writeFile preppedFile (show m')
64 case checkModule senv' m' of
66 do putStrLn "Recheck succeeded"
67 return (senv'',modules ++ [m'])
69 do putStrLn ("Recheck failed: " ++ s)
71 FailC s -> error ("Typechecking failed: " ++ s)
72 Left err -> error ("Parsing failed: " ++ show err)) handler
74 putStrLn ("WARNING: we caught an exception " ++ show e
75 ++ " while processing " ++ f)
76 return (senv, modules)
78 main = do args <- getArgs
79 let (doTest, fnames) =
81 (f:rest) | f == testFlag -> (True,rest)
82 rest@(_:_) -> (False,rest)
84 "usage: ./Driver [filename]"
85 -- Note that we scan over the libraries twice:
86 -- first to gather together all type sigs, then to typecheck them
87 -- (the latter of which doesn't necessarily have to be done every time.)
88 -- This is a hack to avoid dealing with circular dependencies.
90 -- notice: scan over libraries *and* input modules first, not just libs
91 topEnv <- mkInitialEnv (map normalise libs `union` map normalise fnames)
92 doOneProgram doTest topEnv fnames
93 where doOneProgram doTest topEnv fns = do
94 putStrLn $ "========== Program " ++ (show fns) ++ " ================"
95 let numToDo = length (typecheckLibraries fns)
96 (_,modules) <- foldM (process doTest) (topEnv,[]) (typecheckLibraries fns)
97 let succeeded = length modules
98 putStrLn ("Finished typechecking. Successfully checked " ++ show succeeded
99 ++ " out of " ++ show numToDo ++ " modules.")
100 -- TODO: uncomment once interpreter works
101 --let result = evalProgram modules
102 --putStrLn ("Result = " ++ show result)
103 putStrLn "All done\n============================================="
105 typecheckLibraries = if typecheckLibs then (libs ++) else id
106 -- Just my guess as to what's needed from the base libs.
107 -- May well be missing some libraries and have some that
108 -- aren't commonly used.
109 -- However, the following is enough to check all of nofib.
110 -- This points to how nice it would be to have explicit import lists in ext-core.
111 libs = (libDir ["./ghc-prim/GHC/Generics.hcr",
112 "./ghc-prim/GHC/Bool.hcr",
113 "./ghc-prim/GHC/IntWord64.hcr",
114 "./base/GHC/Base.hcr",
115 "./base/Data/Tuple.hcr",
116 "./base/Data/Maybe.hcr",
117 "./integer-gmp/GHC/Integer.hcr",
118 "./base/GHC/List.hcr",
119 "./base/GHC/Enum.hcr",
120 "./base/Data/Ord.hcr",
121 "./base/Data/String.hcr",
122 "./base/Data/Either.hcr",
123 "./base/GHC/Show.hcr",
124 "./base/GHC/Num.hcr",
126 "./base/GHC/STRef.hcr",
127 "./base/GHC/Arr.hcr",
128 "./base/GHC/Real.hcr",
129 "./base/Control/Monad.hcr",
130 "./base/GHC/Int.hcr",
131 "./base/GHC/Unicode.hcr",
132 "./base/Text/ParserCombinators/ReadP.hcr",
133 "./base/Text/Read/Lex.hcr",
134 "./base/Text/ParserCombinators/ReadPrec.hcr",
135 "./base/GHC/Read.hcr",
136 "./base/GHC/Word.hcr",
137 "./base/Data/HashTable.hcr",
138 "./base/Unsafe/Coerce.hcr",
139 "./base/Foreign/Storable.hcr",
140 "./base/Foreign/C/Types.hcr",
141 "./base/GHC/IOBase.hcr",
142 "./base/GHC/ForeignPtr.hcr",
143 "./base/Data/Typeable.hcr",
144 "./base/Data/Dynamic.hcr",
145 "./base/GHC/Err.hcr",
146 "./base/Data/List.hcr",
147 "./base/Data/Char.hcr",
148 "./base/GHC/Pack.hcr",
149 "./base/GHC/Storable.hcr",
150 "./base/System/IO/Error.hcr",
151 "./base/Foreign/Ptr.hcr",
152 "./base/Foreign/Marshal/Error.hcr",
153 "./base/Foreign/ForeignPtr.hcr",
154 "./base/Foreign/Marshal/Alloc.hcr",
155 "./base/Foreign/Marshal/Utils.hcr",
156 "./base/Foreign/Marshal/Array.hcr",
157 "./base/Foreign/C/String.hcr",
158 "./base/Foreign/C/Error.hcr",
159 "./base/Foreign/C.hcr",
160 "./base/System/IO/Unsafe.hcr",
161 "./base/Foreign/Marshal.hcr",
162 "./base/Foreign/StablePtr.hcr",
163 "./base/Foreign.hcr",
164 "./base/System/Posix/Types.hcr",
165 "./base/System/Posix/Internals.hcr",
166 "./base/GHC/Conc.hcr",
167 "./base/Control/Exception.hcr",
168 "./base/GHC/TopHandler.hcr",
169 "./base/Data/Bits.hcr",
170 "./base/Numeric.hcr",
171 "./base/GHC/Ptr.hcr",
172 "./base/GHC/Float.hcr",
173 "./base/GHC/Exception.hcr",
174 "./base/GHC/Stable.hcr",
175 "./base/GHC/Weak.hcr",
176 "./base/GHC/Handle.hcr",
178 "./base/GHC/Dotnet.hcr",
179 "./base/GHC/Environment.hcr",
180 "./base/GHC/Exts.hcr",
181 "./base/GHC/PArr.hcr",
182 "./base/System/IO.hcr",
183 "./base/System/Environment.hcr",
184 "./base/Data/Generics/Basics.hcr",
185 "./base/Data/Complex.hcr",
186 "./array/Data/Array/Base.hcr",
187 "./base/System/Exit.hcr",
188 "./base/Data/Ratio.hcr",
189 "./base/Control/Monad/ST/Lazy.hcr",
190 "./base/Prelude.hcr",
191 "./base/Control/Concurrent/MVar.hcr",
192 "./base/Data/Foldable.hcr"])
194 mkInitialEnv :: [FilePath] -> IO Menv
195 mkInitialEnv libs = foldM mkTypeEnv initialEnv libs
197 mkTypeEnv :: Menv -> FilePath -> IO Menv
198 mkTypeEnv globalEnv fn = catch (do
199 putStrLn $ "mkTypeEnv: reading library " ++ fn
200 resultOrErr <- parseCore fn
202 Right mod@(Module mn _ _) -> do
203 let newE = envsModule globalEnv mod
205 Left err -> do putStrLn ("Failed to parse library module: " ++ show err)
206 error "quit") handler
208 putStrLn ("WARNING: mkTypeEnv caught an exception " ++ show e
209 ++ " while processing " ++ fn)