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