Encode.hs

{-# LANGUAGE OverloadedStrings #-}

module Server.Encode
  ( encodeDiagnostic
  , encodeParseError
  , encodePatch
  , encodeRange
  , encodeLoc
  , encodeUri
  ) where

import Descript.Misc
import qualified Language.Haskell.LSP.Types as J
import Data.Text (Text)
import qualified Data.Text as Text
import Data.Monoid
import Network.URI

encodeDiagnostic :: Diagnostic Range -> J.Diagnostic
encodeDiagnostic diag
  = J.Diagnostic range' severity code source message relatedInformation
  where range' = encodeRange $ getAnn diag
        -- Technically an error, but warnings aren't implemented, and
        -- this distinguishes from parse errors which are more severe.
        severity = Just $ diagTypeSeverity $ diagType
        code = Nothing
        source = Just $ diagTypeSource diagType
        message = Text.pack $ baseSummary diag
        relatedInformation = Just $ J.List []
        diagType = getDiagType diag

diagTypeSeverity :: DiagType -> J.DiagnosticSeverity
diagTypeSeverity DiagProblemType = J.DsWarning
diagTypeSeverity DiagEvalType = J.DsHint

diagTypeSource :: DiagType -> Text
diagTypeSource DiagProblemType = "validate"
diagTypeSource DiagEvalType = "eval"

encodeParseError :: ParseError Char -> [J.Diagnostic]
encodeParseError = map encodeRangedErrMsg . splitParseError

encodeRangedErrMsg :: RangedErrorMsg -> J.Diagnostic
encodeRangedErrMsg (RangedErrorMsg range msg)
  = J.Diagnostic range' severity code source message relatedInformation
  where range' = encodeRange range
        severity = Just J.DsError
        code = Nothing
        source = Just "parse"
        message = "Parse error: " <> Text.pack msg
        relatedInformation = Just $ J.List []

encodePatch :: Patch -> J.List J.TextEdit
-- LSP stores patches from bottom to top, Descript lib stores from top
-- to bottom. Maybe in the future should switch lib to bottom to top.
encodePatch = J.List . map encodeCPatch . reverse . cpatches

encodeCPatch :: CPatch -> J.TextEdit
encodeCPatch (CPatch range text) = J.TextEdit (encodeRange range) text

encodeRange :: Range -> J.Range
encodeRange (Range start' end') = J.Range (encodeLoc start') (encodeLoc end')

encodeLoc :: Loc -> J.Position
encodeLoc (Loc line' column') = J.Position (pred $ unPos line') (pred $ unPos column')

-- TODO Maybe should preserve other URI information, and use MonadThrow
-- instead of error for bad URIs (although both should be caught).
encodeUri :: FilePath -> J.Uri
encodeUri = J.Uri . Text.pack . uriToString' . mkPathURI

uriToString' :: URI -> String
uriToString' x = uriToString id x ""

mkPathURI :: FilePath -> URI
mkPathURI path'
  = URI
  { uriScheme = "file:"
  , uriAuthority = Just nullURIAuth
  , uriPath = path'
  , uriQuery = ""
  , uriFragment = ""
  }

nullURIAuth :: URIAuth
nullURIAuth
  = URIAuth
  { uriUserInfo = ""
  , uriRegName = ""
  , uriPort = ""
  }