{-# LANGUAGE DeriveDataTypeable, DeriveGeneric, RecordWildCards #-}

-- | GHC requests
--
-- GHC requests use "IdeSession.Types.Public" types.
module IdeSession.GHC.Requests (
    GhcInitRequest(..)
  , GhcRequest(..)
  , GhcRunRequest(..)
  , RunCmd(..)
  ) where

import Data.Binary
import Data.ByteString (ByteString)
import Data.Typeable (Typeable)
import Control.Applicative ((<$>), (<*>))

import Text.Show.Pretty (PrettyVal(..))
import GHC.Generics

import IdeSession.Types.Public

-- | Initial handshake with the ghc server
--
-- Ideally we'd send over the entire IdeStaticInfo but this includes some
-- Cabal fields, and the ghc server does -not- compile against Cabal
-- (although this isn't so important anymore now that we use Cabal-ide-backend)
data GhcInitRequest = GhcInitRequest {
    ghcInitClientApiVersion   :: Int
  , ghcInitGenerateModInfo    :: Bool
  , ghcInitOpts               :: [String]
  , ghcInitUserPackageDB      :: Bool
  , ghcInitSpecificPackageDBs :: [String]
  , ghcInitSessionDir         :: FilePath
  , ghcInitSourceDir          :: FilePath
  , ghcInitDistDir            :: !FilePath
  }
  deriving (Typeable, Generic)

data GhcRequest
  = ReqCompile {
        reqCompileGenCode   :: Bool
      , reqCompileTargets   :: Targets
      }
  | ReqRun {
        reqRunCmd :: RunCmd
      }
  | ReqSetEnv {
        reqSetEnv :: [(String, Maybe String)]
      }
  | ReqSetArgs {
        reqSetArgs :: [String]
      }
  | ReqBreakpoint {
        reqBreakpointModule :: ModuleName
      , reqBreakpointSpan   :: SourceSpan
      , reqBreakpointValue  :: Bool
      }
  | ReqPrint {
        reqPrintVars  :: Name
      , reqPrintBind  :: Bool
      , reqPrintForce :: Bool
      }
  | ReqLoad {
        reqLoad :: [FilePath]
      }
  | ReqUnload {
        reqUnload :: [FilePath]
      }
  | ReqSetGhcOpts {
        reqSetGhcOpts :: [String]
      }
    -- | For debugging only! :)
  | ReqCrash {
        reqCrashDelay :: Maybe Int
      }
  deriving (Typeable, Generic, Show)

data RunCmd =
    RunStmt {
        runCmdModule   :: String
      , runCmdFunction :: String
      , runCmdStdout   :: RunBufferMode
      , runCmdStderr   :: RunBufferMode
      , runCmdPty      :: Bool
      }
  | Resume
  deriving (Typeable, Generic, Show)

instance PrettyVal GhcInitRequest
instance PrettyVal GhcRequest
instance PrettyVal RunCmd

data GhcRunRequest =
    GhcRunInput ByteString
  | GhcRunInterrupt
  deriving Typeable

instance Binary GhcInitRequest where
  put (GhcInitRequest{..}) = do
    -- Note: we intentionally write the API version first. This makes it
    -- possible (in theory at least) to have some form of backwards API
    -- compatibility.
    put ghcInitClientApiVersion
    put ghcInitGenerateModInfo
    put ghcInitOpts
    put ghcInitUserPackageDB
    put ghcInitSpecificPackageDBs
    put ghcInitSessionDir
    put ghcInitSourceDir
    put ghcInitDistDir

  get = GhcInitRequest <$> get
                       <*> get
                       <*> get
                       <*> get
                       <*> get
                       <*> get
                       <*> get
                       <*> get

instance Binary GhcRequest where
  put ReqCompile{..} = do
    putWord8 0
    put reqCompileGenCode
    put reqCompileTargets
  put ReqRun{..} = do
    putWord8 1
    put reqRunCmd
  put ReqSetEnv{..} = do
    putWord8 2
    put reqSetEnv
  put ReqSetArgs{..} = do
    putWord8 3
    put reqSetArgs
  put ReqBreakpoint{..} = do
    putWord8 4
    put reqBreakpointModule
    put reqBreakpointSpan
    put reqBreakpointValue
  put ReqPrint{..} = do
    putWord8 5
    put reqPrintVars
    put reqPrintBind
    put reqPrintForce
  put ReqLoad{..} = do
    putWord8 6
    put reqLoad
  put ReqUnload{..} = do
    putWord8 7
    put reqUnload
  put ReqSetGhcOpts{..} = do
    putWord8 8
    put reqSetGhcOpts
  put ReqCrash{..} = do
    putWord8 255
    put reqCrashDelay

  get = do
    header <- getWord8
    case header of
      0   -> ReqCompile     <$> get <*> get
      1   -> ReqRun         <$> get
      2   -> ReqSetEnv      <$> get
      3   -> ReqSetArgs     <$> get
      4   -> ReqBreakpoint  <$> get <*> get <*> get
      5   -> ReqPrint       <$> get <*> get <*> get
      6   -> ReqLoad        <$> get
      7   -> ReqUnload      <$> get
      8   -> ReqSetGhcOpts  <$> get
      255 -> ReqCrash       <$> get
      _   -> fail "GhcRequest.get: invalid header"

instance Binary RunCmd where
  put (RunStmt {..}) = do
    putWord8 2
    put runCmdModule
    put runCmdFunction
    put runCmdStdout
    put runCmdStderr
    put runCmdPty
  put Resume = do
    putWord8 1

  get = do
    header <- getWord8
    case header of
      -- Still respond to requests that use the old binary format.
      0 -> RunStmt <$> get <*> get <*> get <*> get <*> return False
      1 -> return Resume
      2 -> RunStmt <$> get <*> get <*> get <*> get <*> get
      _ -> fail "RunCmd.get: invalid header"

instance Binary GhcRunRequest where
  put (GhcRunInput bs) = putWord8 0 >> put bs
  put GhcRunInterrupt  = putWord8 1

  get = do
    header <- getWord8
    case header of
      0 -> GhcRunInput <$> get
      1 -> return GhcRunInterrupt
      _ -> fail "GhcRunRequest.get: invalid header"