module ServerCom where


-- library imports
import Control.Monad.State
import List ( elemIndex )

-- local imports
import CR
import Lexer
import Parser
import Syntax
import Pretty
import Logging


--
-- Sends a message to the server on standard output
--
sendToServer :: SendMessage -> CR ()
sendToServer msg =
    do debug $ "Sending following message to server: <" ++ showPpr msg ++ ">"
       liftIO $ putStr (showPpr msg)
       debug "Sending done"
       


receiveFromServer :: ParseStateFlag -> CR RecvMessage
receiveFromServer st = 
    do debug $ "Waiting for message from server..."
       msgStr <- readMessageString 
       debug $ "Received the following message string:\n<" ++  msgStr ++ ">"
       let msg = (((flip parse) st) . scan) msgStr
       debug $ "Raw message: <" ++ show msg ++ ">"
       debug $ "The message parsed and pretty printed is:\n" ++ showPpr msg
       return msg
--
-- Reads a message from the server as a string
--
readMessageString :: CR String
readMessageString =
    do msgStart <- readMessageStart
       case msgStart of
         Left singleLine -> return singleLine
         Right (pref, line) ->
             do debug ("start of a multiline message: " ++ pref)
                readUntilMessageEnd pref [line]

--
-- Reads the 1st line of a message. If the line starts with s\ for a string s,
-- then (Right (s, line)) is returned, otherwise (Left line) is returned
--
readMessageStart :: CR (Either String (String, String))
readMessageStart =
    do line <- myGetLine
       case multilineStart line of
         Nothing -> return $ Left (line ++ "\n")
         Just pref -> return $ Right (pref, line ++ "\n")
    where multilineStart line = 
              do i <- elemIndex '\\' line
                 return (take i line)
          

--
-- Takes a "message start" returned by a call to readMessageStart and
-- an accumulator and reads up until the message end which is delimited by 
-- the "message start" followed by a forward-slash. Returns the characters read.
-- Reads a line at a time.
--
-- Relies on fact that lines do not begin with spaces or tabs.
--
readUntilMessageEnd :: String -> [String] -> CR String
readUntilMessageEnd msgStart acc =
    do line <- myGetLine
       if prefix (msgStart ++ "/")  line 
           then let sl = reverse ((line ++ "\n") : acc)
                    in return $ foldr (++) "" sl
           else do readUntilMessageEnd msgStart ((line ++ "\n") : acc)
  where
      prefix str str' = str == take (length str) str'


myGetLine :: CR String
myGetLine = 
    do l <- liftIO getLine
       -- debug ("getLine returned " ++ show l)
       return l