{-# LANGUAGE CPP #-}
{-------------------------------------------------------------------------------

        Copyright:              Bernie Pope 2004

        Module:                 Main

        Description:            The top module in baskell. Implements the
                                read-eval-print loop of the interpreter.

        Primary Authors:        Bernie Pope

-------------------------------------------------------------------------------}

{-
    This file is part of baskell.

    baskell is free software; you can redistribute it and/or modify
    it under the terms of the GNU General Public License as published by
    the Free Software Foundation; either version 2 of the License, or
    (at your option) any later version.

    baskell is distributed in the hope that it will be useful,
    but WITHOUT ANY WARRANTY; without even the implied warranty of
    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
    GNU General Public License for more details.

    You should have received a copy of the GNU General Public License
    along with baskell; if not, write to the Free Software
    Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
-}

module Main where

import Pretty
   ( prettyText )

import Parser
   ( parse )

import AST
   ( Program (..)
   , Decl (..)
   , Exp
   , emptyProgram
   , isEmptyProgram
   )

import System.IO
   ( stdout
   , hSetBuffering
   , BufferMode (NoBuffering)
   )

import Reduce
   ( runExp
   , buildEnv
   , Env
   , joinEnv
   )

import Primitives
   ( primDecls
   , primTypes
   )

import Data.Char
   ( isSpace )

import Rename
   ( renameExp
   , renameProgram
   )

import Type
   ( Type )

import TypeCheck
   ( typeCheckExpression
   , typeCheckProgram
   , Constraint
   , renderConstraints
   )

import Control.Monad
   ( when )

import Depend
   ( depend
   , printDepends
   )

import Help
   ( printHelp )

import CmdLine
   ( Command (..)
   , getCommand
   , initializeCmdLine
   )

import Control.Concurrent
   ( myThreadId
   , ThreadId
   )

import System.Posix.Signals
   ( sigINT
   , installHandler
   , Handler (..)
   )

import Control.Exception
   ( try
   , throwTo
   , Exception (..)
   )

--------------------------------------------------------------------------------

-- the state of the interpreter
data State
   = State
     { state_prelude        :: Program       -- the Prelude functions
     , state_currentProgram :: Program       -- the functions of a loaded module
     , state_currentEnv     :: Env           -- prims + prelude + current
     , state_primEnv        :: Env           -- primitive functions
     , state_primTypes      :: [Constraint]  -- types of primitive functions
     , state_preludeTypes   :: [Constraint]  -- types of Prelude functions
     , state_currentTypes   :: [Constraint]  -- types of loaded module
     , state_count          :: Int           -- unique number (for fresh vars)
     }

main :: IO ()
main = do
   catchCtrlC
   hSetBuffering stdout NoBuffering
   initializeCmdLine
   putStrLn "Welcome to Baskell"
   putStrLn "Bernie's Amazing Super-Kool Equational Low-fat Language"
   initState <- initialiseState
   putStrLn "Type :h for help"
   repLoop initState

catchCtrlC :: IO Handler
catchCtrlC
   = do thisThread <- myThreadId
        installHandler sigINT (Catch (hupHandler thisThread)) Nothing
        where
        hupHandler :: ThreadId -> IO ()
        hupHandler theThread
           = throwTo theThread (ErrorCall "Interrupt Signal")

-- initialise the state of the debugger
--    * set up the primitive functions
--    * load the Prelude
initialiseState :: IO State
initialiseState = do
   putStrLn "Loading the Prelude..."
   let (renamedPrims, primCount)
          = renameProgram (Program primDecls) 0
       primEnv      = buildEnv renamedPrims
       primState    = State
                      { state_prelude        = emptyProgram
                      , state_currentProgram = emptyProgram
                      , state_currentEnv     = primEnv
                      , state_primEnv        = primEnv
                      , state_primTypes      = primTypes
                      , state_preludeTypes   = []
                      , state_currentTypes   = []
                      , state_count          = primCount
                      }
   preludeState <- load primState "Prelude.bs"
   return $ preludeState
            { state_prelude        = state_currentProgram preludeState
            , state_currentProgram = emptyProgram
            , state_preludeTypes   = state_currentTypes preludeState
            , state_currentTypes   = []
            }

-- the Read Eval Print Loop of the interpreter
repLoop :: State -> IO ()
repLoop state = do
   command <- getCommand
   case command of
      Load file -> do
         newState <- load state file
         repLoop newState
      Eval exp -> do
         result <- try $ eval state exp
         case result of
            Left e   -> putStrLn "Interrupted!"
            Right () -> return ()
         repLoop state
      Type exp -> typeExp state exp >> repLoop state
      Browse   -> browse state >> repLoop state
      Quit     -> putStrLn "Leaving baskell."
      Help     -> printHelp >> repLoop state
#ifdef DEBUG
      ShowAST -> do
         putStrLn "The abstract syntax tree:"
         print $ state_currentProgram state
         repLoop state
      ShowDepend -> do
         putStrLn "Function dependencies:"
         printDepends $ state_currentProgram state
         repLoop state
#endif

-- evaluate an expression from the command line
eval :: State -> Exp -> IO ()
eval state exp
   = do let renamedExp = renameExp exp (state_count state)
            finalForm  = runExp (state_currentEnv state) renamedExp
        putStrLn $ prettyText finalForm

-- infer the type of an expression on the command line
typeExp :: State -> Exp -> IO ()
typeExp state exp
   = do let renamedExp  = renameExp exp (state_count state)
            assumptions = state_primTypes state    ++
                          state_preludeTypes state ++
                          state_currentTypes state
        typeCheckExpression assumptions renamedExp

-- load a user defined Baskell module
load :: State -> FilePath -> IO State
load state file = do
   contents <- safeReadFile file
   if null contents
      then return state
      else parseRenameAndType state file contents

-- parse a file, rename identifiers, and type check it
-- if successful update the state of the interpreter
parseRenameAndType :: State -> FilePath -> String -> IO State
parseRenameAndType state file contents
   = do case parse file contents of
           Left e
              -> do putStrLn $ "Parse error: " ++ show e
                    putStrLn $ file ++ " not loaded"
                    return state
           Right program
              -> do putStrLn $ "Load of " ++ file ++ " successful"
                    let oldCount = state_count state
                        (renamed, count) = renameProgram program oldCount
                        assumptions = state_primTypes state ++
                                      state_preludeTypes state
                    programTypes <- typeCheckProgram assumptions renamed
                    let primEnv     = state_primEnv state
                        preludeEnv  = buildEnv $ state_prelude state
                        thisProgEnv = buildEnv renamed
                        currentEnv  = primEnv    `joinEnv`
                                      preludeEnv `joinEnv`
                                      thisProgEnv
                    return $
                       state
                       { state_currentProgram = renamed
                       , state_currentEnv     = currentEnv
                       , state_count          = count
                       , state_currentTypes   = programTypes
                       }

-- try to read a file but catch exceptions
safeReadFile :: FilePath -> IO String
safeReadFile file
   = catch (readFile file)
        $ \e -> do putStrLn $ show e
                   putStrLn "Program not loaded"
                   return []

-- print the types of the primitive functions, Prelude functions
-- and functions from a loaded module if one exists
browse :: State -> IO ()
browse state
   = do display "\n--- Primitive functions ---\n" $ state_primTypes state
        display "\n--- The Prelude ---\n"         $ state_preludeTypes state
        display "\n--- The current program ---\n" $ state_currentTypes state
   where
   display :: String -> [Constraint] -> IO ()
   display header types
      = when (not $ null types) $
           do putStrLn header
              putStrLn $ renderConstraints types