+-- You shouldn't *need* to change anything below this line...
+
+-- Code to check that the external and GHC printers print the same results
+validateResults :: FilePath -> Module -> IO ()
+validateResults origFile m = do
+ let genFile = origFile </> "parsed"
+ writeFile genFile (show m)
+ resultCode <- system $ "diff -u " ++ origFile ++ " " ++ genFile
+ putStrLn $ case resultCode of
+ ExitSuccess -> "Parse validated for " ++ origFile
+ ExitFailure 1 -> "Parse failed to validate for " ++ origFile
+ _ -> "Error diffing files: " ++ origFile ++ " " ++ genFile
+------------------------------------------------------------------------------
+
+data Flag = Test | NoDeps
+ deriving Eq
+
+options :: [OptDescr Flag]
+options =
+ [Option ['t'] ["test"] (NoArg Test) "validate prettyprinted code",
+ Option ['n'] ["no-deps"] (NoArg NoDeps) "don't compute dependencies automatically"
+ ]
+
+process :: Bool -> (Menv,[Module]) -> (FilePath, Module)
+ -> IO (Menv,[Module])
+process _ (senv,modules) p@(f,m) | isLib p && not typecheckLibs = do
+ -- if it's a library and we set typecheckLibs to False:
+ -- prep, but don't typecheck
+ m' <- prepM senv m f
+ return (senv, modules ++ [m'])
+ where isLib (fp,_) = baseDir `isPrefixOf` fp
+process doTest (senv,modules) (f, m@(Module mn _ _)) = catch (do
+ when doTest $ validateResults f m
+ (case checkModule senv m of
+ OkC senv' ->
+ do putStrLn $ "Check succeeded for " ++ show mn
+ m' <- prepM senv' m f
+ case checkModule senv' m' of
+ OkC senv'' ->
+ do putStrLn "Recheck succeeded"
+ return (senv'',modules ++ [m'])
+ FailC s ->
+ do putStrLn ("Recheck failed: " ++ s)
+ error "quit"
+ FailC s -> error ("Typechecking failed: " ++ s))) handler
+ where handler e = do
+ putStrLn ("WARNING: we caught an exception " ++ show e
+ ++ " while processing " ++ f)
+ return (senv, modules)
+
+prepM :: Menv -> Module -> FilePath -> IO Module
+prepM senv' m _f = do
+ let m' = prepModule senv' m
+ --writeFile (f </> ".prepped") (show m')
+ return m'
+
+main :: IO ()
+main = do
+ args <- getArgs
+ case getOpt Permute options args of
+ (opts, fnames@(_:_), _) ->
+ let doTest = Test `elem` opts
+ computeDeps = NoDeps `notElem` opts in
+ doOneProgram computeDeps doTest fnames
+ _ -> error "usage: ./Driver [filename]"
+ where doOneProgram :: Bool -> Bool -> [FilePath] -> IO ()
+ doOneProgram computeDeps doTest fns = do
+ putStrLn $ "========== Program " ++ (show fns) ++ " ============="
+ deps <- if computeDeps
+ then
+ getDependencies fns
+ else (liftM catMaybes) (mapM findModuleDirect fns)
+ putStrLn $ "deps = " ++ show (fst (unzip deps))
+ {-
+ Note that we scan over the libraries twice:
+ first to gather together all type sigs, then to typecheck them
+ (the latter of which doesn't necessarily have to be done every time.)
+ This is a hack to avoid dealing with circular dependencies.
+ -}
+ -- notice: scan over libraries *and* input modules first, not just libs
+ topEnv <- mkInitialEnv (snd (unzip deps))
+ (_,modules) <- foldM (process doTest) (topEnv,[]) deps
+ let succeeded = length modules
+ putStrLn ("Finished typechecking. Successfully checked "
+ ++ show succeeded)
+ overridden <- override modules
+ result <- evalProgram overridden
+ putStrLn ("Result = " ++ show result)
+ putStrLn "All done\n============================================="
+
+ mkInitialEnv :: [Module] -> IO Menv
+ mkInitialEnv libs = foldM mkTypeEnv initialEnv libs
+
+ mkTypeEnv :: Menv -> Module -> IO Menv
+ mkTypeEnv globalEnv m@(Module mn _ _) =
+ catch (return (envsModule globalEnv m)) handler
+ where handler e = do
+ putStrLn ("WARNING: mkTypeEnv caught an exception " ++ show e
+ ++ " while processing " ++ show mn)
+ return globalEnv
+
+findModuleDirect :: FilePath -> IO (Maybe (FilePath, Module))
+-- kludge to let us run "make libtest" --
+-- this module (in the Cabal package) causes an uncaught exception
+-- from Prelude.chr, which I haven't been able to track down
+findModuleDirect fn | "PackageDescription.hcr" `isSuffixOf` fn = return Nothing
+findModuleDirect fn = do
+ putStrLn $ "Finding " ++ show fn
+ res <- parseCore fn
+ case res of
+ Left err -> error (show err)
+ Right m -> return $ Just (fn,m)
\ No newline at end of file