Types.hs

{-# LANGUAGE OverloadedStrings   #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DeriveDataTypeable #-}

-- | Server types.

module FP.Server.Types where

import           FP.API.Types
import           FP.Server.Config

import           Control.Concurrent.STM
import           Control.Monad.Logger hiding (Loc)
import           Control.Monad.Reader
import           Data.Aeson
import           Data.Default
import           Data.Map (Map)
import           Data.Text
import           FP.API.Common
import           GHC.Generics
import           Data.IORef
import           Network.HTTP.Conduit
import           Prelude

-- | Server monad.

type ServerM r = ReaderT (ServerState, r) (LoggingT IO)

type Server = ServerM ProjectId

-- | The configuration for the server and some state.
data ServerState = ServerState
  { serverCC :: ClientConfig
  , serverConfig :: Config
  , serverProjects :: TVar (Map ProjectId (ClientInfo Server))
  }

-- | Simple command configuration.
data ClientConfig = CC
  { ccUrl       :: !Text
  , ccToken     :: !Text
  , ccManager   :: !Manager
  , ccCookie    :: !(IORef CookieJar)
  , ccUserAgent :: !Text
  }

-- | Configuration for server.
data Config = Config
  { configToken :: !Text
  , configUrl   :: !Text
  , configPort  :: !Integer
  , configAgent :: !Text
  , configDebug :: !Bool
  , configStartServer :: !Bool
  } deriving (Show)

instance Default Config where
  def = Config "" defaultUrl defaultPort "fpco-api" True False

-- | Message from the client.
data Msg = MsgSaveModule ProjectId FilePath FilePath
         | MsgCheckModule ProjectId FilePath FilePath FilePath
         | MsgTypeInfo ProjectId FilePath Int Int Int Int
         | MsgGetDefinition ProjectId FilePath FilePath Int Int Int Int
         | MsgAutoComplete ProjectId FilePath Text
         | MsgHoogleIdent ProjectId FilePath Text
         | MsgHoogleDb ProjectId Text
         | MsgDownloadFiles (Either Text ProjectId) FilePath
         | MsgWriteEmacsConfig (Either Text ProjectId) FilePath
         | MsgRunTarget ProjectId
  deriving (Generic,Show)

instance FromJSON Msg
instance ToJSON Msg

-- | A message sent when running a process.
data ProcessMsg
  = MsgStdin Text
  | MsgKill (Maybe ()) -- Because Lisp is stupid.
  deriving (Generic,Show)

instance FromJSON ProcessMsg
instance ToJSON ProcessMsg

-- | Reply to the client.
data Reply = ReplyPong ()
           | ReplyOK ()
           | ReplyCompileMessages [CompileMessage]
           | ReplyCompileInfos [SourceInfo]
           | ReplyTypeInfo [SpanType]
           | ReplyLocation DefinitionLoc
           | ReplyCompletions [Text]
           | ReplyHoogleResults [HoogleResult]
           | ReplyHoogleResult HoogleResult
           | ReplySaveStatus Bool
           | ReplyStdout Text
           | ReplyStderr Text
           | ReplyWebUrl Approot
 deriving (Generic,Show)

instance ToJSON Reply
instance FromJSON Reply

data DefinitionLoc = DefinitionLoc Loc
                   | DefinitionUseless Text
                   | DefinitionImport Text          -- Identifier name
                                      PackageModule -- Module it's defined in
                                      PackageModule -- Module it's imported from
                                      (Maybe Loc)   -- Definition span
                                      (Maybe Loc)   -- Import span
  deriving (Generic,Show)

instance ToJSON DefinitionLoc
instance FromJSON DefinitionLoc

data PackageModule = PackageModule Text -- Package name
                                   Text -- Module name
  deriving (Generic,Show)

instance ToJSON PackageModule
instance FromJSON PackageModule

data Loc = Loc FilePath Int Int Int Int
  deriving (Generic,Show)

instance ToJSON Loc
instance FromJSON Loc

-- | A type info thing.
data SpanType = SpanType Int Int Int Int -- Position
                         Text            -- Source string
                         [Text]          -- Types
  deriving (Generic,Show)

instance ToJSON SpanType
instance FromJSON SpanType

-- | A message from the compiler about code.
data CompileMessage = CompileMessage Text Text Text
   deriving (Show,Generic)

instance ToJSON CompileMessage
instance FromJSON CompileMessage