+++ /dev/null
-{-# 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 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 :: Bool
-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
-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
projects / ghc-hetmet.git / blobdiff