{-# LANGUAGE RecordWildCards #-}
module Dhall.LSP.Backend.Diagnostics
( DhallError
, diagnose
, Diagnosis(..)
, explain
, embedsWithRanges
, offsetToPosition
, Position
, positionFromMegaparsec
, positionToOffset
, Range(..)
, rangeFromDhall
, subtractPosition
)
where
import Dhall.Parser (SourcedException(..), Src(..), unwrap)
import Dhall.TypeCheck (DetailedTypeError(..), ErrorMessages(..), TypeError(..))
import Dhall.Core (Expr(Note, Embed), subExpressions)
import Dhall.LSP.Util
import Dhall.LSP.Backend.Dhall
import Dhall.LSP.Backend.Parsing (getImportLink)
import Control.Lens (toListOf)
import Control.Monad.Trans.Writer (Writer, execWriter, tell)
import Data.Monoid ((<>))
import Data.Text (Text)
import qualified Data.Text as Text
import qualified Data.Text.Prettyprint.Doc.Render.Text as Pretty.Text
import qualified Data.List.NonEmpty as NonEmpty
import qualified Dhall.Pretty
import qualified Dhall.TypeCheck as TypeCheck
import qualified Text.Megaparsec as Megaparsec
type Position = (Int, Int)
data Range = Range {left, right :: Position}
data Diagnosis = Diagnosis {
doctor :: Text,
range :: Maybe Range,
diagnosis :: Text
}
diagnose :: DhallError -> [Diagnosis]
diagnose (ErrorInternal e) = [Diagnosis { .. }]
where
doctor = "Dhall"
range = Nothing
diagnosis =
"An internal error has occurred while trying to process the Dhall file: "
<> tshow e
diagnose (ErrorImportSourced (SourcedException src e)) = [Diagnosis { .. }]
where
doctor = "Dhall.Import"
range = Just (rangeFromDhall src)
diagnosis = tshow e
diagnose (ErrorTypecheck (TypeError _ expr message)) = [Diagnosis { .. }]
where
doctor = "Dhall.TypeCheck"
range = fmap rangeFromDhall (note expr)
diagnosis = "Error: " <> Pretty.Text.renderStrict (Dhall.Pretty.layout short)
ErrorMessages{..} = TypeCheck.prettyTypeMessage message
diagnose (ErrorParse e) =
[ Diagnosis { .. } | (diagnosis, range) <- zip diagnoses (map Just ranges) ]
where
doctor = "Dhall.Parser"
errors = (NonEmpty.toList . Megaparsec.bundleErrors . unwrap) e
diagnoses = map (Text.pack . Megaparsec.parseErrorTextPretty) errors
positions =
map (positionFromMegaparsec . snd) . fst $ Megaparsec.attachSourcePos
Megaparsec.errorOffset
errors
(Megaparsec.bundlePosState (unwrap e))
texts = map parseErrorText errors
ranges =
[ rangeFromDhall (Src left' left' text)
| (left, text) <- zip positions texts
, let left' = positionToMegaparsec left ]
parseErrorText :: Megaparsec.ParseError Text s -> Text
parseErrorText (Megaparsec.TrivialError _ (Just (Megaparsec.Tokens text)) _) =
Text.pack (NonEmpty.toList text)
parseErrorText _ = ""
explain :: DhallError -> Maybe Diagnosis
explain (ErrorTypecheck e@(TypeError _ expr _)) = Just
(Diagnosis { .. })
where
doctor = "Dhall.TypeCheck"
range = fmap rangeFromDhall (note expr)
diagnosis = tshow (DetailedTypeError e)
explain _ = Nothing
note :: Expr s a -> Maybe s
note (Note s _) = Just s
note _ = Nothing
positionFromMegaparsec :: Megaparsec.SourcePos -> Position
positionFromMegaparsec (Megaparsec.SourcePos _ line col) =
(Megaparsec.unPos line - 1, Megaparsec.unPos col - 1)
positionToMegaparsec :: Position -> Megaparsec.SourcePos
positionToMegaparsec (line, col) = Megaparsec.SourcePos ""
(Megaparsec.mkPos $ max 0 line + 1)
(Megaparsec.mkPos $ max 0 col + 1)
addRelativePosition :: Position -> Position -> Position
addRelativePosition (x1, y1) (0, dy2) = (x1, y1 + dy2)
addRelativePosition (x1, _) (dx2, y2) = (x1 + dx2, y2)
subtractPosition :: Position -> Position -> Position
subtractPosition (x1, y1) (x2, y2) | x1 == x2 = (0, y2 - y1)
| otherwise = (x2 - x1, y2)
rangeFromDhall :: Src -> Range
rangeFromDhall (Src left _right text) = Range (x1,y1) (x2,y2)
where
(x1,y1) = positionFromMegaparsec left
(dx2,dy2) = offsetToPosition text . Text.length $ Text.stripEnd text
(x2,y2) = addRelativePosition (x1,y1) (dx2,dy2)
positionToOffset :: Text -> Position -> Int
positionToOffset txt (line, col) = if line < length ls
then Text.length . unlines' $ take line ls ++ [Text.take col (ls !! line)]
else Text.length txt
where ls = NonEmpty.toList (lines' txt)
offsetToPosition :: Text -> Int -> Position
offsetToPosition txt off = (length ls - 1, Text.length (NonEmpty.last ls))
where ls = lines' (Text.take off txt)
embedsWithRanges :: Expr Src a -> [(Range, a)]
embedsWithRanges =
map (\(src, a) -> (rangeFromDhall . getImportLink $ src, a)) . execWriter . go
where go :: Expr Src a -> Writer [(Src, a)] ()
go (Note src (Embed a)) = tell [(src, a)]
go expr = mapM_ go (toListOf subExpressions expr)