{-# 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
type Position = (Int, Int)
data Range = Range {Range -> Position
left, Range -> Position
right :: Position}
data Diagnosis = Diagnosis {
Diagnosis -> Text
doctor :: Text,
Diagnosis -> Maybe Range
range :: Maybe Range,
Diagnosis -> Text
diagnosis :: Text
}
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)
| (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 ]
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
""
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
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
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)
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)
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)
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)
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
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)
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)