X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=utils%2Fext-core%2FDriver.hs;h=c2eee43f49ce8b9cb89e0cafd9a040380498ae60;hp=57d688e0c01c807db3849288e7b753c9afae63aa;hb=b84b5969798530dbf5be9b8bb795b77e5dfbf042;hpb=c287bea94592fffe63f85831ab651c28d64e4d6e

diff --git a/utils/ext-core/Driver.hs b/utils/ext-core/Driver.hs
index 57d688e..c2eee43 100644
--- a/utils/ext-core/Driver.hs
+++ b/utils/ext-core/Driver.hs
@@ -1,5 +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. 
 
@@ -8,19 +7,23 @@
 
 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
@@ -32,8 +35,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,8 +46,17 @@ validateResults origFile m = do
     _             -> "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
@@ -72,7 +82,7 @@ process doTest (senv,modules) (f, m@(Module mn _ _)) = catch (do
                      ++ " 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')
@@ -81,17 +91,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 +117,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