-- 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,
  IdeResultNoDiagnosticsEarlyCutoff) where

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

import           Data.ByteString                           (ByteString)
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)

-- | an IdeResult with a fingerprint
type IdeResultNoDiagnosticsEarlyCutoff  v = (Maybe ByteString, 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 (Int32 |? Text)
-> 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 (Int32 |? Text)
_code = Maybe (Int32 |? Text)
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{UInt
_line :: Position -> UInt
_character :: Position -> UInt
_character :: UInt
_line :: UInt
..} = String -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty (UInt -> String
forall a. Show a => a -> String
show (UInt -> String) -> UInt -> String
forall a b. (a -> b) -> a -> b
$ UInt
_lineUInt -> UInt -> UInt
forall a. Num a => a -> a -> a
+UInt
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
<> String -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty (UInt -> String
forall a. Show a => a -> String
show (UInt -> String) -> UInt -> String
forall a b. (a -> b) -> a -> b
$ UInt
_characterUInt -> UInt -> UInt
forall a. Num a => a -> a -> a
+UInt
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 DiagnosticSeverity
Maybe (Int32 |? Text)
Maybe (List DiagnosticTag)
Maybe (List DiagnosticRelatedInformation)
Text
Range
_relatedInformation :: Maybe (List DiagnosticRelatedInformation)
_tags :: Maybe (List DiagnosticTag)
_message :: Text
_source :: Maybe Text
_code :: Maybe (Int32 |? Text)
_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 (Int32 |? Text)
$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