X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=utils%2Fext-core%2FDriver.hs;h=c2eee43f49ce8b9cb89e0cafd9a040380498ae60;hp=fd42f9eab08fef3d784ec61531f1804d57270024;hb=b84b5969798530dbf5be9b8bb795b77e5dfbf042;hpb=6b085eeada6c3c93599fa4b6d77572abc419c08c diff --git a/utils/ext-core/Driver.hs b/utils/ext-core/Driver.hs index fd42f9e..c2eee43 100644 --- a/utils/ext-core/Driver.hs +++ b/utils/ext-core/Driver.hs @@ -1,98 +1,146 @@ +{-# OPTIONS -Wall #-} {- A simple driver that loads, typechecks, prepares, re-typechecks, and interprets the GHC standard Prelude modules and an application module called Main. Note that, if compiled under GHC, this requires a very large heap to run! -} +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 Printer -import Parser -import Lex -import ParseGlue -import Env -import Prims -import Check -import Prep -import Interp +import Language.Core.Core +import Language.Core.Dependencies +import Language.Core.Overrides +import Language.Core.Prims +import Language.Core.Check +import Language.Core.Prep +import Language.Core.Interp +import Language.Core.ParsecParser -process (senv,modules) f = - do putStrLn ("Processing " ++ f) - s <- readFile f - case parse s 1 of - OkP m -> do putStrLn "Parse succeeded" - {- writeFile (f ++ ".parsed") (show m) -} - case checkModule senv m of - OkC senv' -> - do putStrLn "Check succeeded" - let m' = prepModule senv' m - {- writeFile (f ++ ".prepped") (show m') -} - 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 -> - do putStrLn ("Check failed: " ++ s) - error "quit" - FailP s -> do putStrLn ("Parse failed: " ++ s) - error "quit" +-- You may need to change this. +baseDir :: FilePath +baseDir = "../../libraries/" +-- change to True to typecheck library files as well as reading type signatures +typecheckLibs :: Bool +typecheckLibs = False -main = do fname <- getSingleArg - (_,modules) <- foldM process (initialEnv,[]) [fname] -- flist - let result = evalProgram modules - putStrLn ("Result = " ++ show result) - putStrLn "All done" --- TODO --- see what breaks - where flist = ["Main.hcr"] - getSingleArg = getArgs >>= (\ a -> - case a of - (f:_) -> return f - _ -> error $ "usage: ./Driver [filename]") -{- - ["PrelBase.hcr", - "PrelMaybe.hcr", - "PrelTup.hcr", - "PrelList.hcr", - "PrelShow.hcr", - "PrelEnum.hcr", - "PrelNum.hcr", - "PrelST.hcr", - "PrelArr.hcr", - "PrelDynamic.hcr", - "PrelReal.hcr", - "PrelFloat.hcr", - "PrelRead.hcr", - "PrelIOBase.hcr", - "PrelException.hcr", - "PrelErr.hcr", - "PrelConc.hcr", - "PrelPtr.hcr", - "PrelByteArr.hcr", - "PrelPack.hcr", - "PrelBits.hcr", - "PrelWord.hcr", - "PrelInt.hcr", - "PrelCTypes.hcr", - "PrelStable.hcr", - "PrelCTypesISO.hcr", - "Monad.hcr", - "PrelStorable.hcr", - "PrelMarshalAlloc.hcr", - "PrelMarshalUtils.hcr", - "PrelMarshalArray.hcr", - "PrelCString.hcr", - "PrelMarshalError.hcr", - "PrelCError.hcr", - "PrelPosix.hcr", - "PrelHandle.hcr", - "PrelIO.hcr", - "Prelude.hcr", - "Main.hcr" ] +-- You shouldn't *need* to change anything below this line... --} \ No newline at end of file +-- 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