{-# OPTIONS -Wall #-}
-
{- A simple driver that loads, typechecks, prepares, re-typechecks, and interprets the
GHC standard Prelude modules and an application module called Main.
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 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
-- 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"
_ -> "Error diffing files: " ++ origFile ++ " " ++ genFile
------------------------------------------------------------------------------
-process :: Bool -> (Check.Menv,[Module]) -> (FilePath, Module)
- -> IO (Check.Menv,[Module])
+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
++ " while processing " ++ f)
return (senv, modules)
-prepM :: Check.Menv -> Module -> FilePath -> IO Module
+prepM :: Menv -> Module -> FilePath -> IO Module
prepM senv' m _f = do
let m' = prepModule senv' m
--writeFile (f </> ".prepped") (show m')
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
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