utils/ext-core/Driver.hs

   1 {-# OPTIONS -Wall #-}
   2
   3 {- A simple driver that loads, typechecks, prepares, re-typechecks, and interprets the
   4     GHC standard Prelude modules and an application module called Main.
   5
   6    Note that, if compiled under GHC, this requires a very large heap to run!
   7 -}
   8
   9 import Control.Exception
  10 import Data.List
  11 import Monad
  12 import Prelude hiding (catch)
  13 import System.Cmd
  14 import System.Environment
  15 import System.Exit
  16 import System.FilePath
  17
  18 import Core
  19 import Dependencies
  20 import Prims
  21 import Check
  22 import Prep
  23 import Interp
  24
  25 -- You may need to change this.
  26 baseDir :: FilePath
  27 baseDir = "../../libraries/"
  28 -- change to True to typecheck library files as well as reading type signatures
  29 typecheckLibs :: Bool
  30 typecheckLibs = False
  31
  32 -- You shouldn't *need* to change anything below this line...
  33
  34 -- Code to check that the external and GHC printers print the same results
  35 testFlag :: String
  36 testFlag = "-t"
  37 validateResults :: FilePath -> Module -> IO ()
  38 validateResults origFile m = do
  39   let genFile = origFile </> "parsed"
  40   writeFile genFile (show m)
  41   resultCode <- system $ "diff -u " ++ origFile ++ " " ++ genFile
  42   putStrLn $ case resultCode of
  43     ExitSuccess   -> "Parse validated for " ++ origFile
  44     ExitFailure 1 -> "Parse failed to validate for " ++ origFile
  45     _             -> "Error diffing files: " ++ origFile ++ " " ++ genFile
  46 ------------------------------------------------------------------------------
  47
  48 process :: Bool -> (Check.Menv,[Module]) -> (FilePath, Module)
  49              -> IO (Check.Menv,[Module])
  50 process _ (senv,modules) p@(f,m) | isLib p && not typecheckLibs = do
  51   -- if it's a library and we set typecheckLibs to False:
  52   -- prep, but don't typecheck
  53   m' <- prepM senv m f
  54   return (senv, modules ++ [m'])
  55     where isLib (fp,_) = baseDir `isPrefixOf` fp
  56 process doTest (senv,modules) (f, m@(Module mn _ _)) = catch (do
  57         when doTest $ validateResults f m
  58         (case checkModule senv m of
  59            OkC senv' ->
  60              do putStrLn $ "Check succeeded for " ++ show mn
  61                 m' <- prepM senv' m f
  62                 case checkModule senv' m' of
  63                   OkC senv'' ->
  64                       do putStrLn "Recheck succeeded"
  65                          return (senv'',modules ++ [m'])
  66                   FailC s ->
  67                       do putStrLn ("Recheck failed: " ++ s)
  68                          error "quit"
  69            FailC s -> error ("Typechecking failed: " ++ s))) handler
  70    where handler e = do
  71            putStrLn ("WARNING: we caught an exception " ++ show e
  72                      ++ " while processing " ++ f)
  73            return (senv, modules)
  74
  75 prepM :: Check.Menv -> Module -> FilePath -> IO Module
  76 prepM senv' m _f = do
  77   let m' = prepModule senv' m
  78   --writeFile (f </> ".prepped") (show m')
  79   return m'
  80
  81 main :: IO ()
  82 main = do
  83   args <- getArgs
  84   let (doTest, fnames) =
  85         case args of
  86           (f:rest) | f == testFlag -> (True,rest)
  87           rest@(_:_)               -> (False,rest)
  88           _                        -> error "usage: ./Driver [filename]"
  89   doOneProgram doTest fnames
  90       where  doOneProgram :: Bool -> [FilePath] -> IO ()
  91              doOneProgram doTest fns = do
  92                putStrLn $ "========== Program " ++ (show fns) ++ " ================"
  93                deps <- getDependencies fns
  94                -- putStrLn $ "deps = " ++ show (fst (unzip deps))
  95                {-
  96                  Note that we scan over the libraries twice:
  97                  first to gather together all type sigs, then to typecheck them
  98                  (the latter of which doesn't necessarily have to be done every time.)
  99                  This is a hack to avoid dealing with circular dependencies.
 100                 -}
 101                -- notice: scan over libraries *and* input modules first, not just libs
 102                topEnv <- mkInitialEnv (snd (unzip deps))
 103                (_,modules) <- foldM (process doTest) (topEnv,[]) deps
 104                let succeeded = length modules
 105                putStrLn ("Finished typechecking. Successfully checked "
 106                           ++ show succeeded)
 107                result <- evalProgram modules
 108                putStrLn ("Result = " ++ show result)
 109                putStrLn "All done\n============================================="
 110
 111              mkInitialEnv :: [Module] -> IO Menv
 112              mkInitialEnv libs = foldM mkTypeEnv initialEnv libs
 113
 114              mkTypeEnv :: Menv -> Module -> IO Menv
 115              mkTypeEnv globalEnv m@(Module mn _ _) =
 116                 catch (return (envsModule globalEnv m)) handler
 117                   where handler e = do
 118                           putStrLn ("WARNING: mkTypeEnv caught an exception " ++ show e
 119                                     ++ " while processing " ++ show mn)
 120                           return globalEnv