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 Data.Maybe
  12 import Monad
  13 import Prelude hiding (catch)
  14 import System.Cmd
  15 import System.Console.GetOpt
  16 import System.Environment
  17 import System.Exit
  18 import System.FilePath
  19
  20 import Core
  21 import Dependencies
  22 import Overrides
  23 import Prims
  24 import Check
  25 import Prep
  26 import Interp
  27
  28 import ParsecParser
  29
  30 -- You may need to change this.
  31 baseDir :: FilePath
  32 baseDir = "../../libraries/"
  33 -- change to True to typecheck library files as well as reading type signatures
  34 typecheckLibs :: Bool
  35 typecheckLibs = False
  36
  37 -- You shouldn't *need* to change anything below this line...
  38
  39 -- Code to check that the external and GHC printers print the same results
  40 validateResults :: FilePath -> Module -> IO ()
  41 validateResults origFile m = do
  42   let genFile = origFile </> "parsed"
  43   writeFile genFile (show m)
  44   resultCode <- system $ "diff -u " ++ origFile ++ " " ++ genFile
  45   putStrLn $ case resultCode of
  46     ExitSuccess   -> "Parse validated for " ++ origFile
  47     ExitFailure 1 -> "Parse failed to validate for " ++ origFile
  48     _             -> "Error diffing files: " ++ origFile ++ " " ++ genFile
  49 ------------------------------------------------------------------------------
  50
  51 data Flag = Test | NoDeps
  52   deriving Eq
  53
  54 options :: [OptDescr Flag]
  55 options =
  56   [Option ['t'] ["test"] (NoArg Test) "validate prettyprinted code",
  57    Option ['n'] ["no-deps"] (NoArg NoDeps) "don't compute dependencies automatically"
  58   ]
  59
  60 process :: Bool -> (Check.Menv,[Module]) -> (FilePath, Module)
  61              -> IO (Check.Menv,[Module])
  62 process _ (senv,modules) p@(f,m) | isLib p && not typecheckLibs = do
  63   -- if it's a library and we set typecheckLibs to False:
  64   -- prep, but don't typecheck
  65   m' <- prepM senv m f
  66   return (senv, modules ++ [m'])
  67     where isLib (fp,_) = baseDir `isPrefixOf` fp
  68 process doTest (senv,modules) (f, m@(Module mn _ _)) = catch (do
  69         when doTest $ validateResults f m
  70         (case checkModule senv m of
  71            OkC senv' ->
  72              do putStrLn $ "Check succeeded for " ++ show mn
  73                 m' <- prepM senv' m f
  74                 case checkModule senv' m' of
  75                   OkC senv'' ->
  76                       do putStrLn "Recheck succeeded"
  77                          return (senv'',modules ++ [m'])
  78                   FailC s ->
  79                       do putStrLn ("Recheck failed: " ++ s)
  80                          error "quit"
  81            FailC s -> error ("Typechecking failed: " ++ s))) handler
  82    where handler e = do
  83            putStrLn ("WARNING: we caught an exception " ++ show e
  84                      ++ " while processing " ++ f)
  85            return (senv, modules)
  86
  87 prepM :: Check.Menv -> Module -> FilePath -> IO Module
  88 prepM senv' m _f = do
  89   let m' = prepModule senv' m
  90   --writeFile (f </> ".prepped") (show m')
  91   return m'
  92
  93 main :: IO ()
  94 main = do
  95   args <- getArgs
  96   case getOpt Permute options args of
  97     (opts, fnames@(_:_), _) ->
  98        let doTest      = Test `elem` opts
  99            computeDeps = NoDeps `notElem` opts in
 100          doOneProgram computeDeps doTest fnames
 101     _ -> error "usage: ./Driver [filename]"
 102   where  doOneProgram :: Bool -> Bool -> [FilePath] -> IO ()
 103          doOneProgram computeDeps doTest fns = do
 104                putStrLn $ "========== Program " ++ (show fns) ++ " ============="
 105                deps <- if computeDeps
 106                          then
 107                            getDependencies fns
 108                          else (liftM catMaybes) (mapM findModuleDirect fns)
 109                putStrLn $ "deps = " ++ show (fst (unzip deps))
 110                {-
 111                  Note that we scan over the libraries twice:
 112                  first to gather together all type sigs, then to typecheck them
 113                  (the latter of which doesn't necessarily have to be done every time.)
 114                  This is a hack to avoid dealing with circular dependencies.
 115                 -}
 116                -- notice: scan over libraries *and* input modules first, not just libs
 117                topEnv <- mkInitialEnv (snd (unzip deps))
 118                (_,modules) <- foldM (process doTest) (topEnv,[]) deps
 119                let succeeded = length modules
 120                putStrLn ("Finished typechecking. Successfully checked "
 121                           ++ show succeeded)
 122                overridden <- override modules
 123                result <- evalProgram overridden
 124                putStrLn ("Result = " ++ show result)
 125                putStrLn "All done\n============================================="
 126
 127          mkInitialEnv :: [Module] -> IO Menv
 128          mkInitialEnv libs = foldM mkTypeEnv initialEnv libs
 129
 130          mkTypeEnv :: Menv -> Module -> IO Menv
 131          mkTypeEnv globalEnv m@(Module mn _ _) =
 132                 catch (return (envsModule globalEnv m)) handler
 133                   where handler e = do
 134                           putStrLn ("WARNING: mkTypeEnv caught an exception " ++ show e
 135                                     ++ " while processing " ++ show mn)
 136                           return globalEnv
 137
 138 findModuleDirect :: FilePath -> IO (Maybe (FilePath, Module))
 139 -- kludge to let us run "make libtest" --
 140 -- this module (in the Cabal package) causes an uncaught exception
 141 -- from Prelude.chr, which I haven't been able to track down
 142 findModuleDirect fn | "PackageDescription.hcr" `isSuffixOf` fn = return Nothing
 143 findModuleDirect fn = do
 144   putStrLn $ "Finding " ++ show fn
 145   res <- parseCore fn
 146   case res of
 147     Left err -> error (show err)
 148     Right m -> return $ Just (fn,m)