{-# OPTIONS -fglasgow-exts #-}

module EmacsMonad (
    EmacsM
--  , runInSHM
  , Messages
  , SomeMessage(..)
  , runEmacs
  , sendMsg, cd
  , load, fuzzyCompleteId, simpleCompleteId
  , findDefinition, lookupType
  , Test(..), runTest, acceptTest
  ) where

import Control.Monad.Trans
import Data.Monoid
import Directory
import System.FilePath
import Text.Printf

import Shim.Sexp
import Shim.Messages (simpleCompleteIdentifierMsg, fuzzyCompleteIdentifierMsg
                     ,simpleCompleteModuleMsg, fuzzyCompleteModuleMsg
                     ,loadFileMsg, findDefinitionMsg)
import qualified Shim.Messages as Messages
import Shim.MessagesTH
import Shim.Shim
import Shim.SHM
import Shim.Hsinfo hiding ( load, runTest, findDefinition )


ghcProg = "ghc"

buildMsg :: ConvSexp args => Message args resp -> args -> Sexp
buildMsg (Message name _) args = toS(S name) `mappend` toS args

type Output = [String]
type ErrMsg = String
type Messages = [SomeMessage]
data SomeMessage where Msg :: EmacsM a -> SomeMessage

data EmacsM a where
    SendMsg  :: (Show args, ConvSexp args, ConvSexp resp) => 
                                              Message args resp -> args -> EmacsM resp
    Bind     :: EmacsM a -> (a -> EmacsM b)                             -> EmacsM b
    Return   :: a                                                       -> EmacsM a
    Fail     :: ErrMsg                                                  -> EmacsM a
    SetWD    :: FilePath                                                -> EmacsM ()
    Canonicalize :: FilePath                                            -> EmacsM FilePath
    LiftIO   :: IO a                                                    -> EmacsM a

instance Show (EmacsM a) where
    show (Fail err)  = "Fail with " ++ err
    show (Return _)  = []
    show (Bind m m2) = ";" -- Should never show up in practice
    show (SendMsg msg args) = "Send " ++ showMsg msg args

showMsg (Message name _) args = name ++ show args

instance Show SomeMessage where show (Msg m) = show m

-----------------
-- Monadic API
-----------------


sendMsg :: (Show args, ConvSexp args, ConvSexp resp) => Message args resp -> args -> EmacsM resp
sendMsg = SendMsg

cd :: FilePath -> EmacsM ()
cd = SetWD

canonicalize = Canonicalize

---------------------
-- The actual monad
---------------------
-- What we have here is a kind of convertor, runInSHM,
-- that translates EmacsM computations to 'plain' SHM 
-- computations. Not really so plain, they are actually
-- running in an extended SHM monad with explicit failure,
-- output logging (writer-like) 
-- and message counting&logging (state-like)

type RunningInSHM a = FilePath -> Messages -> SHM (Maybe a, Output, Messages)

instance Monad EmacsM where
  (>>=)  = Bind
  return = Return
  fail   = Fail

instance MonadIO EmacsM where liftIO = LiftIO

runEmacs :: EmacsM a -> IO (Either (Output, Messages, ErrMsg) Output)
runEmacs m = do
--  setLogAction (\_ _ -> return ())
  pwd  <- getCurrentDirectory
  sess <- ghcInit ghcProg
  res  <- runSHM sess ghcProg (runInSHM m pwd [])
  setCurrentDirectory pwd
  case res of
    (Just x,  out, hist)       -> return $ Right out
    (Nothing, (err:out), hist) -> return $ Left (out, hist, err)


runInSHM :: forall a. EmacsM a -> RunningInSHM a

runInSHM cmd@(Fail err) _ hist = return (Nothing, [err], hist)

runInSHM (Return x)     _ hist = return (Just x,  [],        hist)

runInSHM (Bind m f)     root hist = do
  it@(mb_x,  out1, hist') <- runInSHM m root hist
  case mb_x of
    Nothing -> return (Nothing, out1, hist')
    Just x  -> do 
              (x', out2, hist'') <- let cmd = f x in runInSHM cmd root hist'
              return (x', out1 ++ out2, hist'')

runInSHM(SetWD path)   _ hist =
  liftSHM hist $ liftIO $setCurrentDirectory path


runInSHM cmd@(SendMsg msg args) root hist = do
  let msgsexp = buildMsg msg args
  out <- handleCall msgsexp
--          (S ":emacs-rex", length [msg|Msg(SendMsg{}) <- hist], msgsexp)
  case out of 
    Error err -> runInSHM (Fail err) root (Msg cmd : hist)
    Response se -> let sexp      = toS se
                       Just resp = fromS sexp 
                   in return (Just resp, [show sexp], Msg cmd : hist)

runInSHM (LiftIO io) _ hist = liftSHM hist (liftIO io)

runInSHM (Canonicalize fp) rootPath hist = return (Just (rootPath </> fp), [], hist)

liftSHM hist m = m >>= \x -> return (Just x, [], hist)

-------------------
-- Messages
-------------------

load path                = canonicalize path >>= \p -> sendMsg loadFileMsg (p, Nothing)
fuzzyCompleteId file id  = canonicalize file >>= \f -> sendMsg fuzzyCompleteIdentifierMsg (f,id)
simpleCompleteId file id = canonicalize file >>= \f -> sendMsg simpleCompleteIdentifierMsg (f,id)
lookupType     file l c  = canonicalize file >>= \f -> sendMsg Messages.lookupTypeMsg (f, l, c, Nothing)
findDefinition file l c  = canonicalize file >>= \f -> sendMsg Messages.findDefinitionMsg (f, l, c, Nothing)

-----------------------
-- Testing combinators
-----------------------
type Name = String
data Test = forall a. Test {testName::Name, testAction::EmacsM a}

acceptTest (Test name m) = acceptOutput (name ++ ".out") m

runTest :: Test -> IO Bool
runTest (Test name m) = do
  expected <- readFile (name ++ ".out")
  mb_out   <- runEmacs m
  case mb_out of
    Right out           -> writeFile (name ++ ".run.out") (concat out) >>
                           return (concat out == expected)
    Left (out,msgs,err) -> do
                           writeFile (name ++ ".run.out") (concat (err : out))
                           putStrLn $ "Failed with error: " ++ err
                           putStrLn $ "BackTrace of messages: \n" ++ unlines (map show msgs)
                           -- Could also interleave outputs and the backtrace of messages,
                           -- in order to see the answer to each message
                           return False
  


acceptOutput :: FilePath -> EmacsM a -> IO Bool
acceptOutput path m = do
  mb_out <- runEmacs m
  case mb_out of
    Left _ -> return False
    Right out -> writeFile path (concat out) >> return True