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

diff --git a/utils/ext-core/Driver.hs b/utils/ext-core/Driver.hs
index da15dce..57d688e 100644
--- a/utils/ext-core/Driver.hs
+++ b/utils/ext-core/Driver.hs
@@ -1,87 +1,120 @@
+{-# 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 Monad
+import Prelude hiding (catch)
+import System.Cmd
+import System.Environment
+import System.Exit
+import System.FilePath
+
 import Core
-import Printer
-import Parser
-import Lex
-import ParseGlue
-import Env
+import Dependencies
 import Prims
 import Check
 import Prep
 import Interp
 
-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
+
+-- 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"
+  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
+------------------------------------------------------------------------------
+
+process :: Bool -> (Check.Menv,[Module]) -> (FilePath, Module)
+             -> IO (Check.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 :: Check.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
+  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))
+               {-
+                 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)
+               result <- evalProgram modules
+               putStrLn ("Result = " ++ show result)
+               putStrLn "All done\n============================================="
 
-main = do (_,modules) <- foldM process (initialEnv,[]) flist
-	  let result = evalProgram modules
-	  putStrLn ("Result = " ++ show result)
-	  putStrLn "All done"
--- TODO
-       where flist = 	 ["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" ] 
+             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