-- Copyright (c) 2019 The DAML Authors. All rights reserved.
-- SPDX-License-Identifier: Apache-2.0


module Development.IDE.Types.Diagnostics (
  LSP.Diagnostic(..),
  ShowDiagnostic(..),
  FileDiagnostic,
  IdeResult,
  LSP.DiagnosticSeverity(..),
  DiagnosticStore,
  List(..),
  ideErrorText,
  ideErrorWithSource,
  showDiagnostics,
  showDiagnosticsColored,
  ) where

import Control.DeepSeq
import Data.Maybe as Maybe
import qualified Data.Text as T
import Data.Text.Prettyprint.Doc
import Language.Haskell.LSP.Types as LSP (DiagnosticSource,
    DiagnosticSeverity(..)
  , Diagnostic(..)
  , List(..)
  )
import Language.Haskell.LSP.Diagnostics
import Data.Text.Prettyprint.Doc.Render.Text
import qualified Data.Text.Prettyprint.Doc.Render.Terminal as Terminal
import Data.Text.Prettyprint.Doc.Render.Terminal (Color(..), color)

import Development.IDE.Types.Location


-- | The result of an IDE operation. Warnings and errors are in the Diagnostic,
--   and a value is in the Maybe. For operations that throw an error you
--   expect a non-empty list of diagnostics, at least one of which is an error,
--   and a Nothing. For operations that succeed you expect perhaps some warnings
--   and a Just. For operations that depend on other failing operations you may
--   get empty diagnostics and a Nothing, to indicate this phase throws no fresh
--   errors but still failed.
--
--   A rule on a file should only return diagnostics for that given file. It should
--   not propagate diagnostic errors through multiple phases.
type IdeResult v = ([FileDiagnostic], Maybe v)

ideErrorText :: NormalizedFilePath -> T.Text -> FileDiagnostic
ideErrorText :: NormalizedFilePath -> Text -> FileDiagnostic
ideErrorText = Maybe Text
-> Maybe DiagnosticSeverity
-> NormalizedFilePath
-> Text
-> FileDiagnostic
forall a.
Maybe Text
-> Maybe DiagnosticSeverity
-> a
-> Text
-> (a, ShowDiagnostic, Diagnostic)
ideErrorWithSource (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"compiler") (DiagnosticSeverity -> Maybe DiagnosticSeverity
forall a. a -> Maybe a
Just DiagnosticSeverity
DsError)

ideErrorWithSource
  :: Maybe DiagnosticSource
  -> Maybe DiagnosticSeverity
  -> a
  -> T.Text
  -> (a, ShowDiagnostic, Diagnostic)
ideErrorWithSource :: Maybe Text
-> Maybe DiagnosticSeverity
-> a
-> Text
-> (a, ShowDiagnostic, Diagnostic)
ideErrorWithSource Maybe Text
source Maybe DiagnosticSeverity
sev a
fp Text
msg = (a
fp, ShowDiagnostic
ShowDiag, Diagnostic :: Range
-> Maybe DiagnosticSeverity
-> Maybe NumberOrString
-> Maybe Text
-> Text
-> Maybe (List DiagnosticTag)
-> Maybe (List DiagnosticRelatedInformation)
-> Diagnostic
LSP.Diagnostic {
    $sel:_range:Diagnostic :: Range
_range = Range
noRange,
    $sel:_severity:Diagnostic :: Maybe DiagnosticSeverity
_severity = Maybe DiagnosticSeverity
sev,
    $sel:_code:Diagnostic :: Maybe NumberOrString
_code = Maybe NumberOrString
forall a. Maybe a
Nothing,
    $sel:_source:Diagnostic :: Maybe Text
_source = Maybe Text
source,
    $sel:_message:Diagnostic :: Text
_message = Text
msg,
    $sel:_relatedInformation:Diagnostic :: Maybe (List DiagnosticRelatedInformation)
_relatedInformation = Maybe (List DiagnosticRelatedInformation)
forall a. Maybe a
Nothing,
    $sel:_tags:Diagnostic :: Maybe (List DiagnosticTag)
_tags = Maybe (List DiagnosticTag)
forall a. Maybe a
Nothing
    })

-- | Defines whether a particular diagnostic should be reported
--   back to the user.
--
--   One important use case is "missing signature" code lenses,
--   for which we need to enable the corresponding warning during
--   type checking. However, we do not want to show the warning
--   unless the programmer asks for it (#261).
data ShowDiagnostic
    = ShowDiag  -- ^ Report back to the user
    | HideDiag  -- ^ Hide from user
    deriving (ShowDiagnostic -> ShowDiagnostic -> Bool
(ShowDiagnostic -> ShowDiagnostic -> Bool)
-> (ShowDiagnostic -> ShowDiagnostic -> Bool) -> Eq ShowDiagnostic
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ShowDiagnostic -> ShowDiagnostic -> Bool
$c/= :: ShowDiagnostic -> ShowDiagnostic -> Bool
== :: ShowDiagnostic -> ShowDiagnostic -> Bool
$c== :: ShowDiagnostic -> ShowDiagnostic -> Bool
Eq, Eq ShowDiagnostic
Eq ShowDiagnostic
-> (ShowDiagnostic -> ShowDiagnostic -> Ordering)
-> (ShowDiagnostic -> ShowDiagnostic -> Bool)
-> (ShowDiagnostic -> ShowDiagnostic -> Bool)
-> (ShowDiagnostic -> ShowDiagnostic -> Bool)
-> (ShowDiagnostic -> ShowDiagnostic -> Bool)
-> (ShowDiagnostic -> ShowDiagnostic -> ShowDiagnostic)
-> (ShowDiagnostic -> ShowDiagnostic -> ShowDiagnostic)
-> Ord ShowDiagnostic
ShowDiagnostic -> ShowDiagnostic -> Bool
ShowDiagnostic -> ShowDiagnostic -> Ordering
ShowDiagnostic -> ShowDiagnostic -> ShowDiagnostic
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: ShowDiagnostic -> ShowDiagnostic -> ShowDiagnostic
$cmin :: ShowDiagnostic -> ShowDiagnostic -> ShowDiagnostic
max :: ShowDiagnostic -> ShowDiagnostic -> ShowDiagnostic
$cmax :: ShowDiagnostic -> ShowDiagnostic -> ShowDiagnostic
>= :: ShowDiagnostic -> ShowDiagnostic -> Bool
$c>= :: ShowDiagnostic -> ShowDiagnostic -> Bool
> :: ShowDiagnostic -> ShowDiagnostic -> Bool
$c> :: ShowDiagnostic -> ShowDiagnostic -> Bool
<= :: ShowDiagnostic -> ShowDiagnostic -> Bool
$c<= :: ShowDiagnostic -> ShowDiagnostic -> Bool
< :: ShowDiagnostic -> ShowDiagnostic -> Bool
$c< :: ShowDiagnostic -> ShowDiagnostic -> Bool
compare :: ShowDiagnostic -> ShowDiagnostic -> Ordering
$ccompare :: ShowDiagnostic -> ShowDiagnostic -> Ordering
$cp1Ord :: Eq ShowDiagnostic
Ord, Int -> ShowDiagnostic -> ShowS
[ShowDiagnostic] -> ShowS
ShowDiagnostic -> String
(Int -> ShowDiagnostic -> ShowS)
-> (ShowDiagnostic -> String)
-> ([ShowDiagnostic] -> ShowS)
-> Show ShowDiagnostic
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ShowDiagnostic] -> ShowS
$cshowList :: [ShowDiagnostic] -> ShowS
show :: ShowDiagnostic -> String
$cshow :: ShowDiagnostic -> String
showsPrec :: Int -> ShowDiagnostic -> ShowS
$cshowsPrec :: Int -> ShowDiagnostic -> ShowS
Show)

instance NFData ShowDiagnostic where
    rnf :: ShowDiagnostic -> ()
rnf = ShowDiagnostic -> ()
forall a. a -> ()
rwhnf

-- | Human readable diagnostics for a specific file.
--
--   This type packages a pretty printed, human readable error message
--   along with the related source location so that we can display the error
--   on either the console or in the IDE at the right source location.
--
type FileDiagnostic = (NormalizedFilePath, ShowDiagnostic, Diagnostic)

prettyRange :: Range -> Doc Terminal.AnsiStyle
prettyRange :: Range -> Doc AnsiStyle
prettyRange Range{Position
_start :: Range -> Position
_end :: Range -> Position
_end :: Position
_start :: Position
..} = Position -> Doc AnsiStyle
forall ann. Position -> Doc ann
f Position
_start Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall a. Semigroup a => a -> a -> a
<> Doc AnsiStyle
"-" Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall a. Semigroup a => a -> a -> a
<> Position -> Doc AnsiStyle
forall ann. Position -> Doc ann
f Position
_end
    where f :: Position -> Doc ann
f Position{Int
_line :: Position -> Int
_character :: Position -> Int
_character :: Int
_line :: Int
..} = Int -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty (Int
_lineInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
forall ann. Doc ann
colon Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Int -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty (Int
_characterInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1)

stringParagraphs :: T.Text -> Doc a
stringParagraphs :: Text -> Doc a
stringParagraphs = [Doc a] -> Doc a
forall ann. [Doc ann] -> Doc ann
vcat ([Doc a] -> Doc a) -> (Text -> [Doc a]) -> Text -> Doc a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text -> Doc a) -> [Text] -> [Doc a]
forall a b. (a -> b) -> [a] -> [b]
map ([Doc a] -> Doc a
forall ann. [Doc ann] -> Doc ann
fillSep ([Doc a] -> Doc a) -> (Text -> [Doc a]) -> Text -> Doc a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text -> Doc a) -> [Text] -> [Doc a]
forall a b. (a -> b) -> [a] -> [b]
map Text -> Doc a
forall a ann. Pretty a => a -> Doc ann
pretty ([Text] -> [Doc a]) -> (Text -> [Text]) -> Text -> [Doc a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [Text]
T.words) ([Text] -> [Doc a]) -> (Text -> [Text]) -> Text -> [Doc a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [Text]
T.lines

showDiagnostics :: [FileDiagnostic] -> T.Text
showDiagnostics :: [FileDiagnostic] -> Text
showDiagnostics = Doc AnsiStyle -> Text
forall ann. Doc ann -> Text
srenderPlain (Doc AnsiStyle -> Text)
-> ([FileDiagnostic] -> Doc AnsiStyle) -> [FileDiagnostic] -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [FileDiagnostic] -> Doc AnsiStyle
prettyDiagnostics

showDiagnosticsColored :: [FileDiagnostic] -> T.Text
showDiagnosticsColored :: [FileDiagnostic] -> Text
showDiagnosticsColored = Doc AnsiStyle -> Text
srenderColored (Doc AnsiStyle -> Text)
-> ([FileDiagnostic] -> Doc AnsiStyle) -> [FileDiagnostic] -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [FileDiagnostic] -> Doc AnsiStyle
prettyDiagnostics


prettyDiagnostics :: [FileDiagnostic] -> Doc Terminal.AnsiStyle
prettyDiagnostics :: [FileDiagnostic] -> Doc AnsiStyle
prettyDiagnostics = [Doc AnsiStyle] -> Doc AnsiStyle
forall ann. [Doc ann] -> Doc ann
vcat ([Doc AnsiStyle] -> Doc AnsiStyle)
-> ([FileDiagnostic] -> [Doc AnsiStyle])
-> [FileDiagnostic]
-> Doc AnsiStyle
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (FileDiagnostic -> Doc AnsiStyle)
-> [FileDiagnostic] -> [Doc AnsiStyle]
forall a b. (a -> b) -> [a] -> [b]
map FileDiagnostic -> Doc AnsiStyle
prettyDiagnostic

prettyDiagnostic :: FileDiagnostic -> Doc Terminal.AnsiStyle
prettyDiagnostic :: FileDiagnostic -> Doc AnsiStyle
prettyDiagnostic (NormalizedFilePath
fp, ShowDiagnostic
sh, LSP.Diagnostic{Maybe Text
Maybe NumberOrString
Maybe DiagnosticSeverity
Maybe (List DiagnosticTag)
Maybe (List DiagnosticRelatedInformation)
Text
Range
_relatedInformation :: Maybe (List DiagnosticRelatedInformation)
_tags :: Maybe (List DiagnosticTag)
_message :: Text
_source :: Maybe Text
_code :: Maybe NumberOrString
_severity :: Maybe DiagnosticSeverity
_range :: Range
$sel:_tags:Diagnostic :: Diagnostic -> Maybe (List DiagnosticTag)
$sel:_relatedInformation:Diagnostic :: Diagnostic -> Maybe (List DiagnosticRelatedInformation)
$sel:_message:Diagnostic :: Diagnostic -> Text
$sel:_source:Diagnostic :: Diagnostic -> Maybe Text
$sel:_code:Diagnostic :: Diagnostic -> Maybe NumberOrString
$sel:_severity:Diagnostic :: Diagnostic -> Maybe DiagnosticSeverity
$sel:_range:Diagnostic :: Diagnostic -> Range
..}) =
    [Doc AnsiStyle] -> Doc AnsiStyle
forall ann. [Doc ann] -> Doc ann
vcat
        [ String -> Doc AnsiStyle -> Doc AnsiStyle
forall a. String -> Doc a -> Doc a
slabel_ String
"File:    " (Doc AnsiStyle -> Doc AnsiStyle) -> Doc AnsiStyle -> Doc AnsiStyle
forall a b. (a -> b) -> a -> b
$ String -> Doc AnsiStyle
forall a ann. Pretty a => a -> Doc ann
pretty (NormalizedFilePath -> String
fromNormalizedFilePath NormalizedFilePath
fp)
        , String -> Doc AnsiStyle -> Doc AnsiStyle
forall a. String -> Doc a -> Doc a
slabel_ String
"Hidden:  " (Doc AnsiStyle -> Doc AnsiStyle) -> Doc AnsiStyle -> Doc AnsiStyle
forall a b. (a -> b) -> a -> b
$ if ShowDiagnostic
sh ShowDiagnostic -> ShowDiagnostic -> Bool
forall a. Eq a => a -> a -> Bool
== ShowDiagnostic
ShowDiag then Doc AnsiStyle
"no" else Doc AnsiStyle
"yes"
        , String -> Doc AnsiStyle -> Doc AnsiStyle
forall a. String -> Doc a -> Doc a
slabel_ String
"Range:   " (Doc AnsiStyle -> Doc AnsiStyle) -> Doc AnsiStyle -> Doc AnsiStyle
forall a b. (a -> b) -> a -> b
$ Range -> Doc AnsiStyle
prettyRange Range
_range
        , String -> Doc AnsiStyle -> Doc AnsiStyle
forall a. String -> Doc a -> Doc a
slabel_ String
"Source:  " (Doc AnsiStyle -> Doc AnsiStyle) -> Doc AnsiStyle -> Doc AnsiStyle
forall a b. (a -> b) -> a -> b
$ Maybe Text -> Doc AnsiStyle
forall a ann. Pretty a => a -> Doc ann
pretty Maybe Text
_source
        , String -> Doc AnsiStyle -> Doc AnsiStyle
forall a. String -> Doc a -> Doc a
slabel_ String
"Severity:" (Doc AnsiStyle -> Doc AnsiStyle) -> Doc AnsiStyle -> Doc AnsiStyle
forall a b. (a -> b) -> a -> b
$ String -> Doc AnsiStyle
forall a ann. Pretty a => a -> Doc ann
pretty (String -> Doc AnsiStyle) -> String -> Doc AnsiStyle
forall a b. (a -> b) -> a -> b
$ DiagnosticSeverity -> String
forall a. Show a => a -> String
show DiagnosticSeverity
sev
        , String -> Doc AnsiStyle -> Doc AnsiStyle
forall a. String -> Doc a -> Doc a
slabel_ String
"Message: "
            (Doc AnsiStyle -> Doc AnsiStyle) -> Doc AnsiStyle -> Doc AnsiStyle
forall a b. (a -> b) -> a -> b
$ case DiagnosticSeverity
sev of
              DiagnosticSeverity
LSP.DsError -> AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall ann. ann -> Doc ann -> Doc ann
annotate (AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle)
-> AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall a b. (a -> b) -> a -> b
$ Color -> AnsiStyle
color Color
Red
              DiagnosticSeverity
LSP.DsWarning -> AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall ann. ann -> Doc ann -> Doc ann
annotate (AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle)
-> AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall a b. (a -> b) -> a -> b
$ Color -> AnsiStyle
color Color
Yellow
              DiagnosticSeverity
LSP.DsInfo -> AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall ann. ann -> Doc ann -> Doc ann
annotate (AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle)
-> AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall a b. (a -> b) -> a -> b
$ Color -> AnsiStyle
color Color
Blue
              DiagnosticSeverity
LSP.DsHint -> AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall ann. ann -> Doc ann -> Doc ann
annotate (AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle)
-> AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall a b. (a -> b) -> a -> b
$ Color -> AnsiStyle
color Color
Magenta
            (Doc AnsiStyle -> Doc AnsiStyle) -> Doc AnsiStyle -> Doc AnsiStyle
forall a b. (a -> b) -> a -> b
$ Text -> Doc AnsiStyle
forall a. Text -> Doc a
stringParagraphs Text
_message
        ]
    where
        sev :: DiagnosticSeverity
sev = DiagnosticSeverity
-> Maybe DiagnosticSeverity -> DiagnosticSeverity
forall a. a -> Maybe a -> a
fromMaybe DiagnosticSeverity
LSP.DsError Maybe DiagnosticSeverity
_severity


-- | Label a document.
slabel_ :: String -> Doc a -> Doc a
slabel_ :: String -> Doc a -> Doc a
slabel_ String
t Doc a
d = Int -> Doc a -> Doc a
forall ann. Int -> Doc ann -> Doc ann
nest Int
2 (Doc a -> Doc a) -> Doc a -> Doc a
forall a b. (a -> b) -> a -> b
$ [Doc a] -> Doc a
forall ann. [Doc ann] -> Doc ann
sep [String -> Doc a
forall a ann. Pretty a => a -> Doc ann
pretty String
t, Doc a
d]

-- | The layout options used for the SDK assistant.
cliLayout ::
       Int
    -- ^ Rendering width of the pretty printer.
    -> LayoutOptions
cliLayout :: Int -> LayoutOptions
cliLayout Int
renderWidth = LayoutOptions :: PageWidth -> LayoutOptions
LayoutOptions
    { layoutPageWidth :: PageWidth
layoutPageWidth = Int -> Double -> PageWidth
AvailablePerLine Int
renderWidth Double
0.9
    }

-- | Render without any syntax annotations
srenderPlain :: Doc ann -> T.Text
srenderPlain :: Doc ann -> Text
srenderPlain = SimpleDocStream ann -> Text
forall ann. SimpleDocStream ann -> Text
renderStrict (SimpleDocStream ann -> Text)
-> (Doc ann -> SimpleDocStream ann) -> Doc ann -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LayoutOptions -> Doc ann -> SimpleDocStream ann
forall ann. LayoutOptions -> Doc ann -> SimpleDocStream ann
layoutSmart (Int -> LayoutOptions
cliLayout Int
defaultTermWidth)

-- | Render a 'Document' as an ANSII colored string.
srenderColored :: Doc Terminal.AnsiStyle -> T.Text
srenderColored :: Doc AnsiStyle -> Text
srenderColored =
    SimpleDocStream AnsiStyle -> Text
Terminal.renderStrict (SimpleDocStream AnsiStyle -> Text)
-> (Doc AnsiStyle -> SimpleDocStream AnsiStyle)
-> Doc AnsiStyle
-> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
    LayoutOptions -> Doc AnsiStyle -> SimpleDocStream AnsiStyle
forall ann. LayoutOptions -> Doc ann -> SimpleDocStream ann
layoutSmart LayoutOptions
defaultLayoutOptions { layoutPageWidth :: PageWidth
layoutPageWidth = Int -> Double -> PageWidth
AvailablePerLine Int
100 Double
1.0 }

defaultTermWidth :: Int
defaultTermWidth :: Int
defaultTermWidth = Int
80