{-# 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(..), TypeError(..))
import Dhall.Core (Expr(Note, Embed), subExpressions)
import Dhall.LSP.Util
import Dhall.LSP.Backend.Dhall
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.List.NonEmpty as NonEmpty
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 e@(TypeError _ expr _)) = [Diagnosis { .. }]
where
doctor = "Dhall.TypeCheck"
range = fmap rangeFromDhall (note expr)
diagnosis = tshow e
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 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)