content: {-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-}
  -----------------------------------------------------------------------------
  -- |
  -- Module      : Berp.Interpreter.Repl
  -- Copyright   : (c) 2010 Bernie Pope
  -- License     : BSD-style
  -- Maintainer  : florbitous@gmail.com
  -- Stability   : experimental
  -- Portability : ghc
  --
  -- The Read Eval Print Loop (REPL) of the interpreter.
  --
  -----------------------------------------------------------------------------
  
  module Berp.Interpreter.Repl (repl) where
  
  import Data.Typeable (Typeable (..), mkTyConApp, mkTyCon)
  import Control.Monad.Trans (lift, liftIO)
  import Control.Monad (when)
  import System.IO (hSetBuffering, stdout, BufferMode (..))
  import Language.Python.Version3.Parser (parseStmt)
  import Language.Python.Common.Pretty (prettyText)
  import Language.Python.Common.AST (StatementSpan)
  import Language.Haskell.Exts.Pretty
     ( prettyPrintStyleMode, defaultMode, style, Style (..), PPHsMode (..)
     , Mode (..), PPLayout (PPSemiColon))
  import Language.Haskell.Exts.Build (app, qualStmt)
  import Language.Haskell.Exts.Syntax (Exp)
  import Language.Haskell.Interpreter (setImportsQ, as, interpret)
  import Berp.Version (versionString)
  import Berp.Compile.Compile (compile)
  import Berp.Compile.PrimName as Prim (init)
  import Berp.Compile.PySyntaxUtils (InterpreterStmt (..))
  import Berp.Interpreter.Monad (Repl, runRepl, getGlobalScope)
  import Berp.Interpreter.Input (getInputLines)
  import Berp.Base.SemanticTypes (Eval, Object (None), HashTable)
  import Berp.Base (runWithGlobals)
  import Berp.Base.Prims (printObject)
  
  repl :: IO ()
  repl = do
      hSetBuffering stdout NoBuffering
      greeting
      runRepl $ do
         setImportsQ [ ("Data.IntMap", Nothing)
                     , ("Data.IORef", Nothing)
                     , ("Berp.Base", Nothing)
                     , ("Berp.Base.SemanticTypes", Nothing)
                     ]
         replLoop
  
  greeting :: IO ()
  greeting = putStrLn $ "Berp version " ++ versionString ++ ", type control-d to exit."
  
  replLoop :: Repl ()
  replLoop = do
     maybeInput <- getInputLines
     case maybeInput of
        Nothing -> return ()
        Just input -> evalInput input >> replLoop
  
  evalInput :: String -> Repl ()
  evalInput input =
     when (not $ null input) $ do
        pyStmts <- liftIO $ parseAndCheckErrors (input ++ "\n")
        when (not $ null pyStmts) $ do
           exp <- lift $ lift $ compile $ InterpreterStmt pyStmts
           let expStr = oneLinePrinter exp
           comp <- interpret expStr (as :: HashTable -> Eval Object)
           globals <- getGlobalScope
           liftIO $ runWithGlobals globals $ runAndPrint comp
  
  runAndPrint :: (HashTable -> Eval Object) -> HashTable -> Eval Object
  runAndPrint comp globals = do
     -- XXX should catch exceptions here?
     result <- comp globals
     printObjectNotNone result
     return result
  
  oneLinePrinter :: Exp -> String
  oneLinePrinter =
     prettyPrintStyleMode newStyle newMode
     where
     newStyle = style { mode = OneLineMode }
     newMode = defaultMode { layout = PPSemiColon }
  
  parseAndCheckErrors :: String -> IO [StatementSpan]
  parseAndCheckErrors fileContents =
     case parseStmt fileContents "<stdin>" of
        Left e -> (putStrLn $ prettyText e) >> return []
        Right (pyStmt, _comments) -> return pyStmt
  
  printObjectNotNone :: Object -> Eval ()
  printObjectNotNone obj@None = return ()
  printObjectNotNone object = printObject object >> liftIO (putStr "\n")
  
  -- these Typeable instances are needed by the Hint interpret function.
  instance Typeable Object where
     typeOf _ = mkTyConApp (mkTyCon "Object") []
  
  instance Typeable (Eval Object) where
     typeOf _ = mkTyConApp (mkTyCon "Eval") [typeOf (undefined :: Object)]
  