{-# LANGUAGE RecordWildCards #-}

module Dhall.LSP.Backend.Diagnostics
  ( DhallError
  , diagnose
  , Diagnosis(..)
  , explain
  , embedsWithRanges
  , offsetToPosition
  , Position
  , positionFromMegaparsec
  , positionToOffset
  , Range(..)
  , rangeFromDhall
  , subtractPosition
  )
where

import Dhall.Core      (Expr (Embed, Note), subExpressions)
import Dhall.Parser    (SourcedException (..), Src (..), unwrap)
import Dhall.TypeCheck
    ( DetailedTypeError (..)
    , ErrorMessages (..)
    , TypeError (..)
    )

import Dhall.LSP.Backend.Dhall
import Dhall.LSP.Backend.Parsing (getImportLink)
import Dhall.LSP.Util

import Control.Lens               (toListOf)
import Control.Monad.Trans.Writer (Writer, execWriter, tell)
import Data.Text                  (Text)

import qualified Data.List.NonEmpty        as NonEmpty
import qualified Data.Text                 as Text
import qualified Dhall.Pretty
import qualified Dhall.TypeCheck           as TypeCheck
import qualified Prettyprinter.Render.Text as Pretty.Text
import qualified Text.Megaparsec           as Megaparsec

-- | A (line, col) pair representing a position in a source file; 0-based.
type Position = (Int, Int)
-- | A source code range.
data Range = Range {Range -> Position
left, Range -> Position
right :: Position}
-- | A diagnosis, optionally tagged with a source code range.
data Diagnosis = Diagnosis {
    -- | Where the diagnosis came from, e.g. Dhall.TypeCheck.
    Diagnosis -> Text
doctor :: Text,
    Diagnosis -> Maybe Range
range :: Maybe Range,  -- ^ The range of code the diagnosis concerns
    Diagnosis -> Text
diagnosis :: Text
    }


-- | Give a short diagnosis for a given error that can be shown to the end user.
diagnose :: DhallError -> [Diagnosis]
diagnose :: DhallError -> [Diagnosis]
diagnose (ErrorInternal SomeException
e) = [Diagnosis :: Text -> Maybe Range -> Text -> Diagnosis
Diagnosis { Maybe Range
Text
forall a. Maybe a
diagnosis :: Text
range :: forall a. Maybe a
doctor :: Text
diagnosis :: Text
range :: Maybe Range
doctor :: Text
.. }]
  where
    doctor :: Text
doctor = Text
"Dhall"
    range :: Maybe a
range = Maybe a
forall a. Maybe a
Nothing
    diagnosis :: Text
diagnosis =
      Text
"An internal error has occurred while trying to process the Dhall file: "
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> SomeException -> Text
forall a. Show a => a -> Text
tshow SomeException
e

diagnose (ErrorImportSourced (SourcedException Src
src MissingImports
e)) = [Diagnosis :: Text -> Maybe Range -> Text -> Diagnosis
Diagnosis { Maybe Range
Text
diagnosis :: Text
range :: Maybe Range
doctor :: Text
diagnosis :: Text
range :: Maybe Range
doctor :: Text
.. }]
  where
    doctor :: Text
doctor = Text
"Dhall.Import"
    range :: Maybe Range
range = Range -> Maybe Range
forall a. a -> Maybe a
Just (Src -> Range
rangeFromDhall Src
src)
    diagnosis :: Text
diagnosis = MissingImports -> Text
forall a. Show a => a -> Text
tshow MissingImports
e

diagnose (ErrorTypecheck (TypeError Context (Expr Src Void)
_ Expr Src Void
expr TypeMessage Src Void
message)) = [Diagnosis :: Text -> Maybe Range -> Text -> Diagnosis
Diagnosis { Maybe Range
Text
diagnosis :: Text
range :: Maybe Range
doctor :: Text
diagnosis :: Text
range :: Maybe Range
doctor :: Text
.. }]
  where
    doctor :: Text
doctor = Text
"Dhall.TypeCheck"

    range :: Maybe Range
range = (Src -> Range) -> Maybe Src -> Maybe Range
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Src -> Range
rangeFromDhall (Expr Src Void -> Maybe Src
forall s a. Expr s a -> Maybe s
note Expr Src Void
expr)

    diagnosis :: Text
diagnosis = Text
"Error: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> SimpleDocStream Ann -> Text
forall ann. SimpleDocStream ann -> Text
Pretty.Text.renderStrict (Doc Ann -> SimpleDocStream Ann
forall ann. Doc ann -> SimpleDocStream ann
Dhall.Pretty.layout Doc Ann
short)

    ErrorMessages{[Doc Ann]
Doc Ann
short :: ErrorMessages -> Doc Ann
hints :: ErrorMessages -> [Doc Ann]
long :: ErrorMessages -> Doc Ann
long :: Doc Ann
hints :: [Doc Ann]
short :: Doc Ann
..} = TypeMessage Src Void -> ErrorMessages
forall a s. (Eq a, Pretty a) => TypeMessage s a -> ErrorMessages
TypeCheck.prettyTypeMessage TypeMessage Src Void
message

diagnose (ErrorParse ParseError
e) =
  [ Diagnosis :: Text -> Maybe Range -> Text -> Diagnosis
Diagnosis { Maybe Range
Text
range :: Maybe Range
diagnosis :: Text
doctor :: Text
diagnosis :: Text
range :: Maybe Range
doctor :: Text
.. } | (Text
diagnosis, Maybe Range
range) <- [Text] -> [Maybe Range] -> [(Text, Maybe Range)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Text]
diagnoses ((Range -> Maybe Range) -> [Range] -> [Maybe Range]
forall a b. (a -> b) -> [a] -> [b]
map Range -> Maybe Range
forall a. a -> Maybe a
Just [Range]
ranges) ]
  where
    doctor :: Text
doctor = Text
"Dhall.Parser"
    errors :: [ParseError Text Void]
errors = (NonEmpty (ParseError Text Void) -> [ParseError Text Void]
forall a. NonEmpty a -> [a]
NonEmpty.toList (NonEmpty (ParseError Text Void) -> [ParseError Text Void])
-> (ParseError -> NonEmpty (ParseError Text Void))
-> ParseError
-> [ParseError Text Void]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ParseErrorBundle Text Void -> NonEmpty (ParseError Text Void)
forall s e. ParseErrorBundle s e -> NonEmpty (ParseError s e)
Megaparsec.bundleErrors (ParseErrorBundle Text Void -> NonEmpty (ParseError Text Void))
-> (ParseError -> ParseErrorBundle Text Void)
-> ParseError
-> NonEmpty (ParseError Text Void)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ParseError -> ParseErrorBundle Text Void
unwrap) ParseError
e
    diagnoses :: [Text]
diagnoses = (ParseError Text Void -> Text) -> [ParseError Text Void] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (String -> Text
Text.pack (String -> Text)
-> (ParseError Text Void -> String) -> ParseError Text Void -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ParseError Text Void -> String
forall s e.
(VisualStream s, ShowErrorComponent e) =>
ParseError s e -> String
Megaparsec.parseErrorTextPretty) [ParseError Text Void]
errors
    positions :: [Position]
positions =
      ((ParseError Text Void, SourcePos) -> Position)
-> [(ParseError Text Void, SourcePos)] -> [Position]
forall a b. (a -> b) -> [a] -> [b]
map (SourcePos -> Position
positionFromMegaparsec (SourcePos -> Position)
-> ((ParseError Text Void, SourcePos) -> SourcePos)
-> (ParseError Text Void, SourcePos)
-> Position
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ParseError Text Void, SourcePos) -> SourcePos
forall a b. (a, b) -> b
snd) ([(ParseError Text Void, SourcePos)] -> [Position])
-> (([(ParseError Text Void, SourcePos)], PosState Text)
    -> [(ParseError Text Void, SourcePos)])
-> ([(ParseError Text Void, SourcePos)], PosState Text)
-> [Position]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([(ParseError Text Void, SourcePos)], PosState Text)
-> [(ParseError Text Void, SourcePos)]
forall a b. (a, b) -> a
fst (([(ParseError Text Void, SourcePos)], PosState Text)
 -> [Position])
-> ([(ParseError Text Void, SourcePos)], PosState Text)
-> [Position]
forall a b. (a -> b) -> a -> b
$ (ParseError Text Void -> Int)
-> [ParseError Text Void]
-> PosState Text
-> ([(ParseError Text Void, SourcePos)], PosState Text)
forall (t :: * -> *) s a.
(Traversable t, TraversableStream s) =>
(a -> Int) -> t a -> PosState s -> (t (a, SourcePos), PosState s)
Megaparsec.attachSourcePos
        ParseError Text Void -> Int
forall s e. ParseError s e -> Int
Megaparsec.errorOffset
        [ParseError Text Void]
errors
        (ParseErrorBundle Text Void -> PosState Text
forall s e. ParseErrorBundle s e -> PosState s
Megaparsec.bundlePosState (ParseError -> ParseErrorBundle Text Void
unwrap ParseError
e))
    texts :: [Text]
texts = (ParseError Text Void -> Text) -> [ParseError Text Void] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map ParseError Text Void -> Text
forall s. ParseError Text s -> Text
parseErrorText [ParseError Text Void]
errors
    ranges :: [Range]
ranges =
      [ Src -> Range
rangeFromDhall (SourcePos -> SourcePos -> Text -> Src
Src SourcePos
left' SourcePos
left' Text
text)  -- bit of a hack, but convenient.
      | (Position
left, Text
text) <- [Position] -> [Text] -> [(Position, Text)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Position]
positions [Text]
texts
      , let left' :: SourcePos
left' = Position -> SourcePos
positionToMegaparsec Position
left ]
    {- Since Dhall doesn't use custom errors (corresponding to the FancyError
       ParseError constructor) we only need to handle the case of plain
       Megaparsec errors (i.e. TrivialError), and only those who actually
       include a list of tokens that we can compute the length of. -}
    parseErrorText :: Megaparsec.ParseError Text s -> Text
    parseErrorText :: ParseError Text s -> Text
parseErrorText (Megaparsec.TrivialError Int
_ (Just (Megaparsec.Tokens NonEmpty (Token Text)
text)) Set (ErrorItem (Token Text))
_) =
      String -> Text
Text.pack (NonEmpty Char -> String
forall a. NonEmpty a -> [a]
NonEmpty.toList NonEmpty Char
NonEmpty (Token Text)
text)
    parseErrorText ParseError Text s
_ = Text
""

-- | Give a detailed explanation for the given error; if no detailed explanation
--   is available return @Nothing@ instead.
explain :: DhallError -> Maybe Diagnosis
explain :: DhallError -> Maybe Diagnosis
explain (ErrorTypecheck e :: TypeError Src Void
e@(TypeError Context (Expr Src Void)
_ Expr Src Void
expr TypeMessage Src Void
_)) = Diagnosis -> Maybe Diagnosis
forall a. a -> Maybe a
Just
  (Diagnosis :: Text -> Maybe Range -> Text -> Diagnosis
Diagnosis { Maybe Range
Text
diagnosis :: Text
range :: Maybe Range
doctor :: Text
diagnosis :: Text
range :: Maybe Range
doctor :: Text
.. })
  where
    doctor :: Text
doctor = Text
"Dhall.TypeCheck"
    range :: Maybe Range
range = (Src -> Range) -> Maybe Src -> Maybe Range
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Src -> Range
rangeFromDhall (Expr Src Void -> Maybe Src
forall s a. Expr s a -> Maybe s
note Expr Src Void
expr)
    diagnosis :: Text
diagnosis = DetailedTypeError Src Void -> Text
forall a. Show a => a -> Text
tshow (TypeError Src Void -> DetailedTypeError Src Void
forall s a. TypeError s a -> DetailedTypeError s a
DetailedTypeError TypeError Src Void
e)
explain DhallError
_ = Maybe Diagnosis
forall a. Maybe a
Nothing  -- only type errors have detailed explanations so far


-- Given an annotated AST return the note at the top-most node.
note :: Expr s a -> Maybe s
note :: Expr s a -> Maybe s
note (Note s
s Expr s a
_) = s -> Maybe s
forall a. a -> Maybe a
Just s
s
note Expr s a
_ = Maybe s
forall a. Maybe a
Nothing


-- Megaparsec's positions are 1-based while ours are 0-based.
positionFromMegaparsec :: Megaparsec.SourcePos -> Position
positionFromMegaparsec :: SourcePos -> Position
positionFromMegaparsec (Megaparsec.SourcePos String
_ Pos
line Pos
col) =
  (Pos -> Int
Megaparsec.unPos Pos
line Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1, Pos -> Int
Megaparsec.unPos Pos
col Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)

-- Line and column numbers can't be negative. Clamps to 0 just in case.
positionToMegaparsec :: Position -> Megaparsec.SourcePos
positionToMegaparsec :: Position -> SourcePos
positionToMegaparsec (Int
line, Int
col) = String -> Pos -> Pos -> SourcePos
Megaparsec.SourcePos String
""
                                     (Int -> Pos
Megaparsec.mkPos (Int -> Pos) -> Int -> Pos
forall a b. (a -> b) -> a -> b
$ Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
0 Int
line Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)
                                     (Int -> Pos
Megaparsec.mkPos (Int -> Pos) -> Int -> Pos
forall a b. (a -> b) -> a -> b
$ Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
0 Int
col Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)

addRelativePosition :: Position -> Position -> Position
addRelativePosition :: Position -> Position -> Position
addRelativePosition (Int
x1, Int
y1) (Int
0, Int
dy2) = (Int
x1, Int
y1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
dy2)
addRelativePosition (Int
x1, Int
_) (Int
dx2, Int
y2) = (Int
x1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
dx2, Int
y2)

-- | prop> addRelativePosition pos (subtractPosition pos pos') == pos'
subtractPosition :: Position -> Position -> Position
subtractPosition :: Position -> Position -> Position
subtractPosition (Int
x1, Int
y1) (Int
x2, Int
y2) | Int
x1 Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
x2 = (Int
0, Int
y2 Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
y1)
                                   | Bool
otherwise = (Int
x2 Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
x1, Int
y2)

-- | Convert a source range from Dhalls @Src@ format. The returned range is
--   "tight", that is, does not contain any trailing whitespace.
rangeFromDhall :: Src -> Range
rangeFromDhall :: Src -> Range
rangeFromDhall (Src SourcePos
left SourcePos
_right Text
text) = Position -> Position -> Range
Range (Int
x1,Int
y1) (Int
x2,Int
y2)
  where
    (Int
x1,Int
y1) = SourcePos -> Position
positionFromMegaparsec SourcePos
left
    (Int
dx2,Int
dy2) = Text -> Int -> Position
offsetToPosition Text
text (Int -> Position) -> (Text -> Int) -> Text -> Position
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Int
Text.length (Text -> Position) -> Text -> Position
forall a b. (a -> b) -> a -> b
$ Text -> Text
Text.stripEnd Text
text
    (Int
x2,Int
y2) = Position -> Position -> Position
addRelativePosition (Int
x1,Int
y1) (Int
dx2,Int
dy2)

-- Convert a (line,column) position into the corresponding character offset
-- and back, such that the two are inverses of eachother.
positionToOffset :: Text -> Position -> Int
positionToOffset :: Text -> Position -> Int
positionToOffset Text
txt (Int
line, Int
col) = if Int
line Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< [Text] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Text]
ls
  then Text -> Int
Text.length (Text -> Int) -> ([Text] -> Text) -> [Text] -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Text] -> Text
unlines' ([Text] -> Int) -> [Text] -> Int
forall a b. (a -> b) -> a -> b
$ Int -> [Text] -> [Text]
forall a. Int -> [a] -> [a]
take Int
line [Text]
ls [Text] -> [Text] -> [Text]
forall a. [a] -> [a] -> [a]
++ [Int -> Text -> Text
Text.take Int
col ([Text]
ls [Text] -> Int -> Text
forall a. [a] -> Int -> a
!! Int
line)]
  else Text -> Int
Text.length Text
txt  -- position lies outside txt
  where ls :: [Text]
ls = NonEmpty Text -> [Text]
forall a. NonEmpty a -> [a]
NonEmpty.toList (Text -> NonEmpty Text
lines' Text
txt)

offsetToPosition :: Text -> Int -> Position
offsetToPosition :: Text -> Int -> Position
offsetToPosition Text
txt Int
off = (NonEmpty Text -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length NonEmpty Text
ls Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1, Text -> Int
Text.length (NonEmpty Text -> Text
forall a. NonEmpty a -> a
NonEmpty.last NonEmpty Text
ls))
  where ls :: NonEmpty Text
ls = Text -> NonEmpty Text
lines' (Int -> Text -> Text
Text.take Int
off Text
txt)

-- | Collect all `Embed` constructors (i.e. imports if the expression has type
--   `Expr Src Import`) wrapped in a Note constructor and return them together
--   with their associated range in the source code.
embedsWithRanges :: Expr Src a -> [(Range, a)]
embedsWithRanges :: Expr Src a -> [(Range, a)]
embedsWithRanges =
  ((Src, a) -> (Range, a)) -> [(Src, a)] -> [(Range, a)]
forall a b. (a -> b) -> [a] -> [b]
map (\(Src
src, a
a) -> (Src -> Range
rangeFromDhall (Src -> Range) -> (Src -> Src) -> Src -> Range
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Src -> Src
getImportLink (Src -> Range) -> Src -> Range
forall a b. (a -> b) -> a -> b
$ Src
src, a
a)) ([(Src, a)] -> [(Range, a)])
-> (Expr Src a -> [(Src, a)]) -> Expr Src a -> [(Range, a)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Writer [(Src, a)] () -> [(Src, a)]
forall w a. Writer w a -> w
execWriter (Writer [(Src, a)] () -> [(Src, a)])
-> (Expr Src a -> Writer [(Src, a)] ()) -> Expr Src a -> [(Src, a)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Expr Src a -> Writer [(Src, a)] ()
forall a. Expr Src a -> Writer [(Src, a)] ()
go
  where go :: Expr Src a -> Writer [(Src, a)] ()
        go :: Expr Src a -> Writer [(Src, a)] ()
go (Note Src
src (Embed a
a)) = [(Src, a)] -> Writer [(Src, a)] ()
forall (m :: * -> *) w. Monad m => w -> WriterT w m ()
tell [(Src
src, a
a)]
        go Expr Src a
expr = (Expr Src a -> Writer [(Src, a)] ())
-> [Expr Src a] -> Writer [(Src, a)] ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Expr Src a -> Writer [(Src, a)] ()
forall a. Expr Src a -> Writer [(Src, a)] ()
go (Getting (Endo [Expr Src a]) (Expr Src a) (Expr Src a)
-> Expr Src a -> [Expr Src a]
forall a s. Getting (Endo [a]) s a -> s -> [a]
toListOf Getting (Endo [Expr Src a]) (Expr Src a) (Expr Src a)
forall (f :: * -> *) s a.
Applicative f =>
(Expr s a -> f (Expr s a)) -> Expr s a -> f (Expr s a)
subExpressions Expr Src a
expr)