utils/ext-core/Driver.hs

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