X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=utils%2Fext-core%2FDriver.hs;h=c2eee43f49ce8b9cb89e0cafd9a040380498ae60;hp=684f31f7351c4a3f981972dde2d9daa3beaf9dba;hb=b84b5969798530dbf5be9b8bb795b77e5dfbf042;hpb=420a27dc9fb7de5fc6c96fe078ddd4dc87222d44 diff --git a/utils/ext-core/Driver.hs b/utils/ext-core/Driver.hs index 684f31f..c2eee43 100644 --- a/utils/ext-core/Driver.hs +++ b/utils/ext-core/Driver.hs @@ -1,3 +1,4 @@ +{-# OPTIONS -Wall #-} {- A simple driver that loads, typechecks, prepares, re-typechecks, and interprets the GHC standard Prelude modules and an application module called Main. @@ -6,36 +7,38 @@ import Control.Exception import Data.List -import Maybe +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 ParsecParser -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 -- You may need to change this. +baseDir :: FilePath baseDir = "../../libraries/" -- change to True to typecheck library files as well as reading type signatures -typecheckLibs = False +typecheckLibs :: Bool +typecheckLibs = False -- You shouldn't *need* to change anything below this line... -libDir = map (baseDir ++) -- Code to check that the external and GHC printers print the same results -testFlag = "-t" - -validateResults :: FilePath -> FilePath -> IO () -validateResults origFile genFile = do +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 @@ -43,168 +46,101 @@ validateResults origFile genFile = do _ -> "Error diffing files: " ++ origFile ++ " " ++ genFile ------------------------------------------------------------------------------ -process :: Bool -> (Check.Menv,[Module]) -> FilePath - -> IO (Check.Menv,[Module]) -process doTest (senv,modules) f = catch - (do putStrLn ("Processing " ++ f) - resultOrErr <- parseCore f - case resultOrErr of - Right m@(Module mn _ _) -> do - putStrLn "Parse succeeded" - let outF = f ++ ".parsed" - writeFile outF (show m) - when doTest $ (validateResults f outF) - case checkModule senv m of - OkC senv' -> - do putStrLn $ "Check succeeded for " ++ show mn - let m' = prepModule senv' m - let (dir,fname) = splitFileName f - let preppedFile = dir (fname ++ ".prepped") - writeFile preppedFile (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 -> error ("Typechecking failed: " ++ s) - Left err -> error ("Parsing failed: " ++ show err)) handler +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) -main = do args <- getArgs - let (doTest, fnames) = - case args of - (f:rest) | f == testFlag -> (True,rest) - rest@(_:_) -> (False,rest) - _ -> error $ - "usage: ./Driver [filename]" - -- 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. +prepM :: Menv -> Module -> FilePath -> IO Module +prepM senv' m _f = do + let m' = prepModule senv' m + --writeFile (f ".prepped") (show m') + return m' - -- notice: scan over libraries *and* input modules first, not just libs - topEnv <- mkInitialEnv (map normalise libs `union` map normalise fnames) - doOneProgram doTest topEnv fnames - where doOneProgram doTest topEnv fns = do - putStrLn $ "========== Program " ++ (show fns) ++ " ================" - let numToDo = length (typecheckLibraries fns) - (_,modules) <- foldM (process doTest) (topEnv,[]) (typecheckLibraries fns) - let succeeded = length modules - putStrLn ("Finished typechecking. Successfully checked " ++ show succeeded - ++ " out of " ++ show numToDo ++ " modules.") - -- TODO: uncomment once interpreter works - --let result = evalProgram modules - --putStrLn ("Result = " ++ show result) - putStrLn "All done\n=============================================" +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=============================================" - typecheckLibraries = if typecheckLibs then (libs ++) else id - -- Just my guess as to what's needed from the base libs. - -- May well be missing some libraries and have some that - -- aren't commonly used. - -- However, the following is enough to check all of nofib. - -- This points to how nice it would be to have explicit import lists in ext-core. - libs = (libDir ["./ghc-prim/GHC/Generics.hcr", - "./ghc-prim/GHC/Bool.hcr", - "./ghc-prim/GHC/IntWord64.hcr", - "./base/GHC/Base.hcr", - "./base/Data/Tuple.hcr", - "./base/Data/Maybe.hcr", - "./integer-gmp/GHC/Integer.hcr", - "./base/GHC/List.hcr", - "./base/GHC/Enum.hcr", - "./base/Data/Ord.hcr", - "./base/Data/String.hcr", - "./base/Data/Either.hcr", - "./base/GHC/Show.hcr", - "./base/GHC/Num.hcr", - "./base/GHC/ST.hcr", - "./base/GHC/STRef.hcr", - "./base/GHC/Arr.hcr", - "./base/GHC/Real.hcr", - "./base/Control/Monad.hcr", - "./base/GHC/Int.hcr", - "./base/GHC/Unicode.hcr", - "./base/Text/ParserCombinators/ReadP.hcr", - "./base/Text/Read/Lex.hcr", - "./base/Text/ParserCombinators/ReadPrec.hcr", - "./base/GHC/Read.hcr", - "./base/GHC/Word.hcr", - "./base/Data/HashTable.hcr", - "./base/Unsafe/Coerce.hcr", - "./base/Foreign/Storable.hcr", - "./base/Foreign/C/Types.hcr", - "./base/GHC/IOBase.hcr", - "./base/GHC/ForeignPtr.hcr", - "./base/Data/Typeable.hcr", - "./base/Data/Dynamic.hcr", - "./base/GHC/Err.hcr", - "./base/Data/List.hcr", - "./base/Data/Char.hcr", - "./base/GHC/Pack.hcr", - "./base/GHC/Storable.hcr", - "./base/System/IO/Error.hcr", - "./base/Foreign/Ptr.hcr", - "./base/Foreign/Marshal/Error.hcr", - "./base/Foreign/ForeignPtr.hcr", - "./base/Foreign/Marshal/Alloc.hcr", - "./base/Foreign/Marshal/Utils.hcr", - "./base/Foreign/Marshal/Array.hcr", - "./base/Foreign/C/String.hcr", - "./base/Foreign/C/Error.hcr", - "./base/Foreign/C.hcr", - "./base/System/IO/Unsafe.hcr", - "./base/Foreign/Marshal.hcr", - "./base/Foreign/StablePtr.hcr", - "./base/Foreign.hcr", - "./base/System/Posix/Types.hcr", - "./base/System/Posix/Internals.hcr", - "./base/GHC/Conc.hcr", - "./base/Control/Exception.hcr", - "./base/GHC/TopHandler.hcr", - "./base/Data/Bits.hcr", - "./base/Numeric.hcr", - "./base/GHC/Ptr.hcr", - "./base/GHC/Float.hcr", - "./base/GHC/Exception.hcr", - "./base/GHC/Stable.hcr", - "./base/GHC/Weak.hcr", - "./base/GHC/Handle.hcr", - "./base/GHC/IO.hcr", - "./base/GHC/Dotnet.hcr", - "./base/GHC/Environment.hcr", - "./base/GHC/Exts.hcr", - "./base/GHC/PArr.hcr", - "./base/System/IO.hcr", - "./base/System/Environment.hcr", - "./base/Data/Generics/Basics.hcr", - "./base/Data/Complex.hcr", - "./array/Data/Array/Base.hcr", - "./base/System/Exit.hcr", - "./base/Data/Ratio.hcr", - "./base/Control/Monad/ST/Lazy.hcr", - "./base/Prelude.hcr", - "./base/Control/Concurrent/MVar.hcr", - "./base/Data/Foldable.hcr"]) + mkInitialEnv :: [Module] -> IO Menv + mkInitialEnv libs = foldM mkTypeEnv initialEnv libs -mkInitialEnv :: [FilePath] -> 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 -mkTypeEnv :: Menv -> FilePath -> IO Menv -mkTypeEnv globalEnv fn = catch (do - putStrLn $ "mkTypeEnv: reading library " ++ fn - resultOrErr <- parseCore fn - case resultOrErr of - Right mod@(Module mn _ _) -> do - let newE = envsModule globalEnv mod - return newE - Left err -> do putStrLn ("Failed to parse library module: " ++ show err) - error "quit") handler - where handler e = do - putStrLn ("WARNING: mkTypeEnv caught an exception " ++ show e - ++ " while processing " ++ fn) - 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