{-# OPTIONS -Wall #-}
{- A simple driver that loads, typechecks, prepares, re-typechecks, and interprets the 
    GHC standard Prelude modules and an application module called Main. 

   Note that, if compiled under GHC, this requires a very large heap to run!
-}

import Control.Exception
import Data.List
import Data.Maybe
import Monad
import Prelude hiding (catch)
import System.Cmd
import System.Console.GetOpt
import System.Environment
import System.Exit
import System.FilePath

import Language.Core.Core
import Language.Core.Dependencies
import Language.Core.Overrides
import Language.Core.Prims
import Language.Core.Check
import Language.Core.Prep
import Language.Core.Interp
import Language.Core.ParsecParser

-- You may need to change this.
baseDir :: FilePath
baseDir = "../../libraries/"
-- change to True to typecheck library files as well as reading type signatures
typecheckLibs :: Bool
typecheckLibs = False

-- You shouldn't *need* to change anything below this line...                  

-- Code to check that the external and GHC printers print the same results
validateResults :: FilePath -> Module -> IO ()
validateResults origFile m = do
  let genFile = origFile </> "parsed"
  writeFile genFile (show m) 
  resultCode <- system $ "diff -u " ++ origFile ++ " " ++ genFile
  putStrLn $ case resultCode of
    ExitSuccess   -> "Parse validated for " ++ origFile
    ExitFailure 1 -> "Parse failed to validate for " ++ origFile
    _             -> "Error diffing files: " ++ origFile ++ " " ++ genFile
------------------------------------------------------------------------------

data Flag = Test | NoDeps
  deriving Eq

options :: [OptDescr Flag]
options =
  [Option ['t'] ["test"] (NoArg Test) "validate prettyprinted code",
   Option ['n'] ["no-deps"] (NoArg NoDeps) "don't compute dependencies automatically"
  ]

process :: Bool -> (Menv,[Module]) -> (FilePath, Module)
             -> IO (Menv,[Module])
process _ (senv,modules) p@(f,m) | isLib p && not typecheckLibs = do
  -- if it's a library and we set typecheckLibs to False:
  -- prep, but don't typecheck
  m' <- prepM senv m f
  return (senv, modules ++ [m'])
    where isLib (fp,_) = baseDir `isPrefixOf` fp
process doTest (senv,modules) (f, m@(Module mn _ _)) = catch (do
        when doTest $ validateResults f m
	(case checkModule senv m of
           OkC senv' ->
	     do putStrLn $ "Check succeeded for " ++ show mn
                m' <- prepM senv' m f
		case checkModule senv' m' of
                  OkC senv'' ->
		      do putStrLn "Recheck succeeded"
                         return (senv'',modules ++ [m'])
		  FailC s -> 
		      do putStrLn ("Recheck failed: " ++ s)
			 error "quit"
	   FailC s -> error ("Typechecking failed: " ++ s))) handler
   where handler e = do
           putStrLn ("WARNING: we caught an exception " ++ show e 
                     ++ " while processing " ++ f)
           return (senv, modules)

prepM :: Menv -> Module -> FilePath -> IO Module
prepM senv' m _f = do
  let m' = prepModule senv' m
  --writeFile (f </> ".prepped") (show m')
  return m'

main :: IO ()
main = do
  args <- getArgs
  case getOpt Permute options args of
    (opts, fnames@(_:_), _) ->
       let doTest      = Test `elem` opts
           computeDeps = NoDeps `notElem` opts in
         doOneProgram computeDeps doTest fnames
    _ -> error "usage: ./Driver [filename]"
  where  doOneProgram :: Bool -> Bool -> [FilePath] -> IO ()
         doOneProgram computeDeps doTest fns = do
               putStrLn $ "========== Program " ++ (show fns) ++ " ============="
               deps <- if computeDeps 
                         then
                           getDependencies fns
                         else (liftM catMaybes) (mapM findModuleDirect fns)
               putStrLn $ "deps = " ++ show (fst (unzip deps))
               {-
                 Note that we scan over the libraries twice:
                 first to gather together all type sigs, then to typecheck them
                 (the latter of which doesn't necessarily have to be done every time.)
                 This is a hack to avoid dealing with circular dependencies. 
                -}
               -- notice: scan over libraries *and* input modules first, not just libs
               topEnv <- mkInitialEnv (snd (unzip deps))
               (_,modules) <- foldM (process doTest) (topEnv,[]) deps
               let succeeded = length modules
               putStrLn ("Finished typechecking. Successfully checked " 
                          ++ show succeeded)
               overridden <- override modules
               result <- evalProgram overridden
               putStrLn ("Result = " ++ show result)
               putStrLn "All done\n============================================="

         mkInitialEnv :: [Module] -> IO Menv
         mkInitialEnv libs = foldM mkTypeEnv initialEnv libs

         mkTypeEnv :: Menv -> Module -> IO Menv
         mkTypeEnv globalEnv m@(Module mn _ _) = 
                catch (return (envsModule globalEnv m)) handler
                  where handler e = do
                          putStrLn ("WARNING: mkTypeEnv caught an exception " ++ show e 
                                    ++ " while processing " ++ show mn)
                          return globalEnv

findModuleDirect :: FilePath -> IO (Maybe (FilePath, Module))
-- kludge to let us run "make libtest" -- 
-- this module (in the Cabal package) causes an uncaught exception
-- from Prelude.chr, which I haven't been able to track down
findModuleDirect fn | "PackageDescription.hcr" `isSuffixOf` fn = return Nothing
findModuleDirect fn = do
  putStrLn $ "Finding " ++ show fn
  res <- parseCore fn
  case res of
    Left err -> error (show err)
    Right m -> return $ Just (fn,m)