X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=utils%2Fext-core%2FDriver.hs;h=927a95d7f37d0401e1a57dc244bbbb57e807bb1b;hp=57d688e0c01c807db3849288e7b753c9afae63aa;hb=8bfeb25ae78e99c7014113468b0057342db4208f;hpb=044805225a08d5e370b72d2efed66880912b0806 diff --git a/utils/ext-core/Driver.hs b/utils/ext-core/Driver.hs index 57d688e..927a95d 100644 --- a/utils/ext-core/Driver.hs +++ b/utils/ext-core/Driver.hs @@ -8,20 +8,25 @@ import Control.Exception import Data.List +import Data.Maybe import Monad import Prelude hiding (catch) import System.Cmd +import System.Console.GetOpt import System.Environment import System.Exit import System.FilePath import Core import Dependencies +import Overrides import Prims import Check import Prep import Interp +import ParsecParser + -- You may need to change this. baseDir :: FilePath baseDir = "../../libraries/" @@ -32,8 +37,6 @@ typecheckLibs = False -- You shouldn't *need* to change anything below this line... -- Code to check that the external and GHC printers print the same results -testFlag :: String -testFlag = "-t" validateResults :: FilePath -> Module -> IO () validateResults origFile m = do let genFile = origFile "parsed" @@ -45,6 +48,15 @@ validateResults origFile m = do _ -> "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 -> (Check.Menv,[Module]) -> (FilePath, Module) -> IO (Check.Menv,[Module]) process _ (senv,modules) p@(f,m) | isLib p && not typecheckLibs = do @@ -81,17 +93,20 @@ prepM senv' m _f = do main :: IO () main = do args <- getArgs - let (doTest, fnames) = - case args of - (f:rest) | f == testFlag -> (True,rest) - rest@(_:_) -> (False,rest) - _ -> error "usage: ./Driver [filename]" - doOneProgram doTest fnames - where doOneProgram :: Bool -> [FilePath] -> IO () - doOneProgram doTest fns = do - putStrLn $ "========== Program " ++ (show fns) ++ " ================" - deps <- getDependencies fns - -- putStrLn $ "deps = " ++ show (fst (unzip deps)) + 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 @@ -104,17 +119,30 @@ main = do let succeeded = length modules putStrLn ("Finished typechecking. Successfully checked " ++ show succeeded) - result <- evalProgram modules + overridden <- override modules + result <- evalProgram overridden putStrLn ("Result = " ++ show result) putStrLn "All done\n=============================================" - mkInitialEnv :: [Module] -> IO Menv - mkInitialEnv libs = foldM mkTypeEnv initialEnv libs + mkInitialEnv :: [Module] -> IO Menv + mkInitialEnv libs = foldM mkTypeEnv initialEnv libs - mkTypeEnv :: Menv -> Module -> IO Menv - mkTypeEnv globalEnv m@(Module mn _ _) = + 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