Types.hs

{-# OPTIONS -fno-warn-orphans #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE OverloadedStrings   #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE TypeSynonymInstances #-}

-- | Server types.

module FP.Server.Types where

import FP.API.Run
import FP.API.Types

import Control.Concurrent (MVar)
import Control.Monad.Logger
import Control.Monad.Reader
import Data.Aeson
import Data.Default
import Data.Map (Map)
import Data.Maybe
import Data.Text as T
import GHC.Generics

-- | Server monad.
type Server = LoggingT (ReaderT ServerReader IO)

-- | The configuration for the server and some state.
data ServerReader = ServerReader
  { serverCC :: ClientConfig
  , serverConfig :: Config
  , serverPollers :: MVar (Map FayProjectId [Callback])
  , serverTokens :: MVar (MVar (Map FilePath FayTutorialToken))
  }

-- | A callback that will look at incoming messages and determine
-- whether it's what it wants.
newtype Callback = Callback (Maybe Int -> RunnerMessage -> Server Done)

-- | Is the callback done looking for what it wants?
data Done = NotDone | Done
  deriving Eq

-- | Necessary for the pollers map.
deriving instance Ord FayProjectId

-- | Necessary for calling Fay API functions.
instance MonadClient Server where
  getClientConfig = asks serverCC

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

instance Default Config where
  def = Config "" "https://fpcomplete.com" 1990 "fpco-api" True False

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

instance FromJSON Msg
instance ToJSON Msg

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

instance ToJSON Reply
instance FromJSON Reply

data DefinitionLoc = DefinitionLoc Loc
                   | DefinitionUseless Text
                   | DefinitionImport Text        -- Dunno
                                      ModuleId    -- Package
                                      ModuleId    -- Package 2.0 (?)
                                      (Maybe Loc) -- Span
                                      (Maybe Loc) -- Span 2.0
  deriving (Generic,Show)

instance ToJSON DefinitionLoc
instance FromJSON DefinitionLoc

data ModuleId = ModuleId Text Text
  deriving (Generic,Show)

instance ToJSON ModuleId
instance FromJSON ModuleId

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

instance FromJSON FayProjectId where
  parseJSON v = fmap (FayProjectId . T.pack . (show :: Int -> String))
                     (parseJSON v)

instance ToJSON FayProjectId where
  toJSON (FayProjectId i) =
    toJSON ((fromMaybe (error ("Unable to read: " ++ show i)) .
             fmap fst .
             listToMaybe)
              (reads (T.unpack i) :: [(Int,String)]))

-- Only for communication between fpco-client and fpco-server. These
-- types would not be nice to handle outside of Haskell.

deriving instance Generic SourceInfo
instance ToJSON SourceInfo
instance FromJSON SourceInfo

deriving instance Generic SourceInfoKind
instance ToJSON SourceInfoKind
instance FromJSON SourceInfoKind

deriving instance Generic EitherSpan
instance ToJSON EitherSpan
instance FromJSON EitherSpan

deriving instance Generic SourceSpan
instance ToJSON SourceSpan
instance FromJSON SourceSpan

deriving instance Generic FayFileName
instance ToJSON FayFileName
instance FromJSON FayFileName

deriving instance Generic FayModuleName
instance ToJSON FayModuleName
instance FromJSON FayModuleName

deriving instance Generic HoogleResult
instance ToJSON HoogleResult
instance FromJSON HoogleResult

deriving instance Generic PackageLink
instance ToJSON PackageLink
instance FromJSON PackageLink

deriving instance Generic ModuleLink
instance ToJSON ModuleLink
instance FromJSON ModuleLink