utils/ext-core/Driver.hs

   1 {- A simple driver that loads, typechecks, prepares, re-typechecks, and interprets the
   2     GHC standard Prelude modules and an application module called Main.
   3
   4    Note that, if compiled under GHC, this requires a very large heap to run!
   5 -}
   6
   7 import Control.Exception
   8 import Data.List
   9 import Maybe
  10 import Monad
  11 import Prelude hiding (catch)
  12 import System.Cmd
  13 import System.Environment
  14 import System.Exit
  15 import System.FilePath
  16
  17 import Core
  18 import Printer
  19 import ParsecParser
  20 import Env
  21 import Prims
  22 import Check
  23 import Prep
  24 import Interp
  25
  26 -- You may need to change this.
  27 baseDir = "../../libraries/"
  28 -- change to True to typecheck library files as well as reading type signatures
  29 typecheckLibs = False
  30
  31 -- You shouldn't *need* to change anything below this line...
  32 libDir = map (baseDir ++)
  33
  34 -- Code to check that the external and GHC printers print the same results
  35 testFlag = "-t"
  36
  37 validateResults :: FilePath -> FilePath -> IO ()
  38 validateResults origFile genFile = do
  39   resultCode <- system $ "diff -u " ++ origFile ++ " " ++ genFile
  40   putStrLn $ case resultCode of
  41     ExitSuccess   -> "Parse validated for " ++ origFile
  42     ExitFailure 1 -> "Parse failed to validate for " ++ origFile
  43     _             -> "Error diffing files: " ++ origFile ++ " " ++ genFile
  44 ------------------------------------------------------------------------------
  45
  46 process :: Bool -> (Check.Menv,[Module]) -> FilePath
  47              -> IO (Check.Menv,[Module])
  48 process doTest (senv,modules) f = catch
  49       (do putStrLn ("Processing " ++ f)
  50           resultOrErr <- parseCore f
  51           case resultOrErr of
  52             Right m@(Module mn _ _) -> do
  53                         putStrLn "Parse succeeded"
  54                         let outF = f ++ ".parsed"
  55                         writeFile outF (show m)
  56                         when doTest $ (validateResults f outF)
  57                         case checkModule senv m of
  58                           OkC senv' ->
  59                             do putStrLn $ "Check succeeded for " ++ show mn
  60                                let m' = prepModule senv' m
  61                                let (dir,fname) = splitFileName f
  62                                let preppedFile = dir </> (fname ++ ".prepped")
  63                                writeFile preppedFile (show m')
  64                                case checkModule senv' m' of
  65                                  OkC senv'' ->
  66                                    do putStrLn "Recheck succeeded"
  67                                       return (senv'',modules ++ [m'])
  68                                  FailC s ->
  69                                    do putStrLn ("Recheck failed: " ++ s)
  70                                       error "quit"
  71                           FailC s -> error ("Typechecking failed: " ++ s)
  72             Left err -> error ("Parsing failed: " ++ show err)) handler
  73    where handler e = do
  74            putStrLn ("WARNING: we caught an exception " ++ show e
  75                      ++ " while processing " ++ f)
  76            return (senv, modules)
  77
  78 main = do args <- getArgs
  79           let (doTest, fnames) =
  80                  case args of
  81                    (f:rest) | f == testFlag -> (True,rest)
  82                    rest@(_:_)                   -> (False,rest)
  83                    _                        -> error $
  84                                               "usage: ./Driver [filename]"
  85           -- Note that we scan over the libraries twice:
  86           -- first to gather together all type sigs, then to typecheck them
  87           -- (the latter of which doesn't necessarily have to be done every time.)
  88           -- This is a hack to avoid dealing with circular dependencies.
  89
  90           -- notice: scan over libraries *and* input modules first, not just libs
  91           topEnv <- mkInitialEnv (map normalise libs `union` map normalise fnames)
  92           doOneProgram doTest topEnv fnames
  93             where  doOneProgram doTest topEnv fns = do
  94                       putStrLn $ "========== Program " ++ (show fns) ++ " ================"
  95                       let numToDo = length (typecheckLibraries fns)
  96                       (_,modules) <- foldM (process doTest) (topEnv,[]) (typecheckLibraries fns)
  97                       let succeeded = length modules
  98                       putStrLn ("Finished typechecking. Successfully checked " ++ show succeeded
  99                          ++ " out of " ++ show numToDo ++ " modules.")
 100                       -- TODO: uncomment once interpreter works
 101                       --let result = evalProgram modules
 102                       --putStrLn ("Result = " ++ show result)
 103                       putStrLn "All done\n============================================="
 104
 105                    typecheckLibraries = if typecheckLibs then (libs ++) else id
 106                    -- Just my guess as to what's needed from the base libs.
 107                    -- May well be missing some libraries and have some that
 108                    -- aren't commonly used.
 109                    -- However, the following is enough to check all of nofib.
 110                    -- This points to how nice it would be to have explicit import lists in ext-core.
 111                    libs = (libDir ["./ghc-prim/GHC/Generics.hcr",
 112                            "./ghc-prim/GHC/Bool.hcr",
 113                            "./ghc-prim/GHC/IntWord64.hcr",
 114                            "./base/GHC/Base.hcr",
 115                            "./base/Data/Tuple.hcr",
 116                            "./base/Data/Maybe.hcr",
 117                            "./integer-gmp/GHC/Integer.hcr",
 118                            "./base/GHC/List.hcr",
 119                            "./base/GHC/Enum.hcr",
 120                            "./base/Data/Ord.hcr",
 121                            "./base/Data/String.hcr",
 122                            "./base/Data/Either.hcr",
 123                            "./base/GHC/Show.hcr",
 124                            "./base/GHC/Num.hcr",
 125                            "./base/GHC/ST.hcr",
 126                            "./base/GHC/STRef.hcr",
 127                            "./base/GHC/Arr.hcr",
 128                            "./base/GHC/Real.hcr",
 129                            "./base/Control/Monad.hcr",
 130                            "./base/GHC/Int.hcr",
 131                            "./base/GHC/Unicode.hcr",
 132                            "./base/Text/ParserCombinators/ReadP.hcr",
 133                            "./base/Text/Read/Lex.hcr",
 134                            "./base/Text/ParserCombinators/ReadPrec.hcr",
 135                            "./base/GHC/Read.hcr",
 136                            "./base/GHC/Word.hcr",
 137                            "./base/Data/HashTable.hcr",
 138                            "./base/Unsafe/Coerce.hcr",
 139                            "./base/Foreign/Storable.hcr",
 140                            "./base/Foreign/C/Types.hcr",
 141                            "./base/GHC/IOBase.hcr",
 142                            "./base/GHC/ForeignPtr.hcr",
 143                            "./base/Data/Typeable.hcr",
 144                            "./base/Data/Dynamic.hcr",
 145                            "./base/GHC/Err.hcr",
 146                            "./base/Data/List.hcr",
 147                            "./base/Data/Char.hcr",
 148                            "./base/GHC/Pack.hcr",
 149                            "./base/GHC/Storable.hcr",
 150                            "./base/System/IO/Error.hcr",
 151                            "./base/Foreign/Ptr.hcr",
 152                            "./base/Foreign/Marshal/Error.hcr",
 153                            "./base/Foreign/ForeignPtr.hcr",
 154                            "./base/Foreign/Marshal/Alloc.hcr",
 155                            "./base/Foreign/Marshal/Utils.hcr",
 156                            "./base/Foreign/Marshal/Array.hcr",
 157                            "./base/Foreign/C/String.hcr",
 158                            "./base/Foreign/C/Error.hcr",
 159                            "./base/Foreign/C.hcr",
 160                            "./base/System/IO/Unsafe.hcr",
 161                            "./base/Foreign/Marshal.hcr",
 162                            "./base/Foreign/StablePtr.hcr",
 163                            "./base/Foreign.hcr",
 164                            "./base/System/Posix/Types.hcr",
 165                            "./base/System/Posix/Internals.hcr",
 166                            "./base/GHC/Conc.hcr",
 167                            "./base/Control/Exception.hcr",
 168                            "./base/GHC/TopHandler.hcr",
 169                            "./base/Data/Bits.hcr",
 170                            "./base/Numeric.hcr",
 171                            "./base/GHC/Ptr.hcr",
 172                            "./base/GHC/Float.hcr",
 173                            "./base/GHC/Exception.hcr",
 174                            "./base/GHC/Stable.hcr",
 175                            "./base/GHC/Weak.hcr",
 176                            "./base/GHC/Handle.hcr",
 177                            "./base/GHC/IO.hcr",
 178                            "./base/GHC/Dotnet.hcr",
 179                            "./base/GHC/Environment.hcr",
 180                            "./base/GHC/Exts.hcr",
 181                            "./base/GHC/PArr.hcr",
 182                            "./base/System/IO.hcr",
 183                            "./base/System/Environment.hcr",
 184                            "./base/Data/Generics/Basics.hcr",
 185                            "./base/Data/Complex.hcr",
 186                            "./array/Data/Array/Base.hcr",
 187                            "./base/System/Exit.hcr",
 188                            "./base/Data/Ratio.hcr",
 189                            "./base/Control/Monad/ST/Lazy.hcr",
 190                            "./base/Prelude.hcr",
 191                            "./base/Control/Concurrent/MVar.hcr",
 192                            "./base/Data/Foldable.hcr"])
 193
 194 mkInitialEnv :: [FilePath] -> IO Menv
 195 mkInitialEnv libs = foldM mkTypeEnv initialEnv libs
 196
 197 mkTypeEnv :: Menv -> FilePath -> IO Menv
 198 mkTypeEnv globalEnv fn = catch (do
 199   putStrLn $ "mkTypeEnv: reading library " ++ fn
 200   resultOrErr <- parseCore fn
 201   case resultOrErr of
 202     Right mod@(Module mn _ _) -> do
 203        let newE = envsModule globalEnv mod
 204        return newE
 205     Left  err -> do putStrLn ("Failed to parse library module: " ++ show err)
 206                     error "quit") handler
 207   where handler e = do
 208            putStrLn ("WARNING: mkTypeEnv caught an exception " ++ show e
 209                      ++ " while processing " ++ fn)
 210            return globalEnv