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 Monad
   8 import System.Environment
   9 import System.Cmd
  10 import System.Exit
  11
  12 import Core
  13 import Printer
  14 import ParsecParser
  15 import Env
  16 import Prims
  17 import Check
  18 import Prep
  19 import Interp
  20
  21 -- You may need to change this.
  22 baseDir = "../../libraries/"
  23 --------
  24
  25 -- Code for checking that the external and GHC printers print the same results
  26 testFlag = "-t"
  27
  28 validateResults :: FilePath -> FilePath -> IO ()
  29 validateResults origFile genFile = do
  30   resultCode <- system $ "diff -u " ++ origFile ++ " " ++ genFile
  31   putStrLn $ case resultCode of
  32     ExitSuccess   -> "Parse validated for " ++ origFile
  33     ExitFailure 1 -> "Parse failed to validate for " ++ origFile
  34     _             -> "Error diffing files: " ++ origFile ++ " " ++ genFile
  35 ------------------------------------------------------------------------------
  36
  37 process :: Bool -> (Check.Menv,[Module]) -> String -> IO (Check.Menv,[Module])
  38 process doTest (senv,modules) f =
  39        do putStrLn ("Processing " ++ f)
  40           resultOrErr <- parseCore f
  41           case resultOrErr of
  42             Right m -> do
  43                         putStrLn "Parse succeeded"
  44                         let outF = f ++ ".parsed"
  45                         writeFile outF (show m)
  46                         when doTest $ (validateResults f outF)
  47                         case checkModule senv m of
  48                           OkC senv' ->
  49                             do putStrLn "Check succeeded"
  50                                let m' = prepModule senv' m
  51                                {- writeFile (f ++ ".prepped") (show m') -}
  52                                case checkModule senv m' of
  53                                  OkC senv'' ->
  54                                    do putStrLn "Recheck succeeded"
  55                                       return (senv'',modules ++ [m'])
  56                                  FailC s ->
  57                                    do putStrLn ("Recheck failed: " ++ s)
  58                                       error "quit"
  59                           FailC s ->
  60                             do putStrLn ("Check failed: " ++ s)
  61                                error "quit"
  62             Left err -> do putStrLn ("Parse failed: " ++ show err)
  63                            error "quit"
  64
  65 main = do args <- getArgs
  66           let (doTest, fname) =
  67                  case args of
  68                    (f:fn:_) | f == testFlag -> (True,fn)
  69                    (fn:_)                   -> (False,fn)
  70                    _                        -> error $
  71                                               "usage: ./Driver [filename]"
  72           mapM_ (process doTest (initialEnv,[])) (libs ++ [fname])
  73           (_,modules) <- foldM (process doTest) (initialEnv,[]) (libs ++ [fname])
  74           let result = evalProgram modules
  75           putStrLn ("Result = " ++ show result)
  76           putStrLn "All done"
  77             where  libs = map (baseDir ++) ["./ghc-prim/GHC/Generics.hcr",
  78                            "./ghc-prim/GHC/PrimopWrappers.hcr",
  79                            "./ghc-prim/GHC/Bool.hcr",
  80                            "./ghc-prim/GHC/IntWord64.hcr",
  81                            "./base/GHC/Base.hcr",
  82                            "./base/GHC/List.hcr",
  83                            "./base/GHC/Enum.hcr",
  84                            "./base/GHC/Show.hcr",
  85                            "./base/GHC/Num.hcr",
  86                            "./base/GHC/ST.hcr",
  87                            "./base/GHC/Real.hcr",
  88                            "./base/GHC/STRef.hcr",
  89                            "./base/GHC/Arr.hcr",
  90                            "./base/GHC/Float.hcr",
  91                            "./base/GHC/Read.hcr",
  92                            "./base/GHC/Ptr.hcr",
  93                            "./base/GHC/Word.hcr",
  94                            "./base/GHC/Int.hcr",
  95                            "./base/GHC/Unicode.hcr",
  96                            "./base/GHC/IOBase.hcr",
  97                            "./base/GHC/Err.hcr",
  98                            "./base/GHC/Exception.hcr",
  99                            "./base/GHC/Stable.hcr",
 100                            "./base/GHC/Storable.hcr",
 101                            "./base/GHC/Pack.hcr",
 102                            "./base/GHC/Weak.hcr",
 103                            "./base/GHC/Handle.hcr",
 104                            "./base/GHC/IO.hcr",
 105                            "./base/GHC/Dotnet.hcr",
 106                            "./base/GHC/Environment.hcr",
 107                            "./base/GHC/Exts.hcr",
 108                            "./base/GHC/PArr.hcr",
 109                            "./base/GHC/TopHandler.hcr",
 110                            "./base/GHC/Desugar.hcr",
 111                            "./base/Data/Ord.hcr",
 112                            "./base/Data/Maybe.hcr",
 113                            "./base/Data/Bits.hcr",
 114                            "./base/Data/STRef/Lazy.hcr",
 115                            "./base/Data/Generics/Basics.hcr",
 116                            "./base/Data/Generics/Aliases.hcr",
 117                            "./base/Data/Generics/Twins.hcr",
 118                            "./base/Data/Generics/Instances.hcr",
 119                            "./base/Data/Generics/Text.hcr",
 120                            "./base/Data/Generics/Schemes.hcr",
 121                            "./base/Data/Tuple.hcr",
 122                            "./base/Data/String.hcr",
 123                            "./base/Data/Either.hcr",
 124                            "./base/Data/Char.hcr",
 125                            "./base/Data/List.hcr",
 126                            "./base/Data/HashTable.hcr",
 127                            "./base/Data/Typeable.hcr",
 128                            "./base/Data/Dynamic.hcr",
 129                            "./base/Data/Function.hcr",
 130                            "./base/Data/IORef.hcr",
 131                            "./base/Data/Fixed.hcr",
 132                            "./base/Data/Monoid.hcr",
 133                            "./base/Data/Ratio.hcr",
 134                            "./base/Data/STRef.hcr",
 135                            "./base/Data/Version.hcr",
 136                            "./base/Data/Complex.hcr",
 137                            "./base/Data/Unique.hcr",
 138                            "./base/Data/Foldable.hcr",
 139                            "./base/Data/Traversable.hcr"]