diff --git a/diagnose.cabal b/diagnose.cabal index c1ca713..92928f6 100644 --- a/diagnose.cabal +++ b/diagnose.cabal @@ -70,12 +70,15 @@ library build-depends: containers ==0.6.2.1 , megaparsec >=9.0.0 + if flag(parsec-compat) + build-depends: + parsec >=3.1.14 if flag(megaparsec-compat) exposed-modules: Error.Diagnose.Compat.Megaparsec if flag(parsec-compat) exposed-modules: - Error.Diagnose.Compat.Megaparsec + Error.Diagnose.Compat.Parsec default-language: Haskell2010 test-suite diagnose-megaparsec-tests @@ -108,10 +111,50 @@ test-suite diagnose-megaparsec-tests build-depends: containers ==0.6.2.1 , megaparsec >=9.0.0 + if flag(parsec-compat) + build-depends: + parsec >=3.1.14 if !(flag(megaparsec-compat)) buildable: False default-language: Haskell2010 +test-suite diagnose-parsec-tests + type: exitcode-stdio-1.0 + main-is: Spec.hs + other-modules: + Paths_diagnose + hs-source-dirs: + test/parsec + default-extensions: + OverloadedStrings + LambdaCase + BlockArguments + ghc-options: -Wall -Wextra -threaded -rtsopts -with-rtsopts=-N -O0 -g + build-depends: + base >=4.7 && <5 + , bytestring ==0.10.12.0 + , data-default ==0.7.1.1 + , diagnose + , hashable ==1.3.0.0 + , prettyprinter ==1.7.0 + , prettyprinter-ansi-terminal ==1.1.2 + , text ==1.2.4.1 + , unordered-containers ==0.2.14.0 + if flag(json) + cpp-options: -DUSE_AESON + build-depends: + aeson ==1.5.6.0 + if flag(megaparsec-compat) + build-depends: + containers ==0.6.2.1 + , megaparsec >=9.0.0 + if flag(parsec-compat) + build-depends: + parsec >=3.1.14 + if !(flag(parsec-compat)) + buildable: False + default-language: Haskell2010 + test-suite diagnose-rendering-tests type: exitcode-stdio-1.0 main-is: Spec.hs @@ -142,4 +185,7 @@ test-suite diagnose-rendering-tests build-depends: containers ==0.6.2.1 , megaparsec >=9.0.0 + if flag(parsec-compat) + build-depends: + parsec >=3.1.14 default-language: Haskell2010 diff --git a/package.yaml b/package.yaml index b9a7a94..44b67c2 100644 --- a/package.yaml +++ b/package.yaml @@ -33,7 +33,7 @@ library: - Error.Diagnose.Compat.Megaparsec - condition: flag(parsec-compat) exposed-modules: - - Error.Diagnose.Compat.Megaparsec + - Error.Diagnose.Compat.Parsec flags: json: @@ -62,6 +62,9 @@ when: dependencies: - megaparsec >= 9.0.0 - containers == 0.6.2.1 + - condition: flag(parsec-compat) + dependencies: + - parsec >= 3.1.14 ghc-options: - -Wall @@ -95,3 +98,18 @@ tests: when: - condition: ! '!(flag(megaparsec-compat))' buildable: false + diagnose-parsec-tests: + main: Spec.hs + source-dirs: test/parsec + ghc-options: + - -threaded + - -rtsopts + - -with-rtsopts=-N + - -O0 + - -g + dependencies: + - diagnose + when: + - condition: ! '!(flag(parsec-compat))' + buildable: false + diff --git a/src/Error/Diagnose/Compat/Parsec.hs b/src/Error/Diagnose/Compat/Parsec.hs new file mode 100644 index 0000000..a324ab5 --- /dev/null +++ b/src/Error/Diagnose/Compat/Parsec.hs @@ -0,0 +1,92 @@ +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE FlexibleContexts #-} + +{-# OPTIONS -Wno-name-shadowing #-} + +module Error.Diagnose.Compat.Parsec +( diagnosticFromParseError +, errorDiagnosticFromParseError +, warningDiagnosticFromParseError +, module Error.Diagnose.Compat.Hints +) where + +import Data.Bifunctor (second) +import Data.Function ((&)) +import Data.Maybe (fromMaybe) +import Data.List (intercalate) +import Data.String (IsString(..)) +import Data.Void (Void) + +import Error.Diagnose +import Error.Diagnose.Compat.Hints (HasHints(..)) + +import qualified Text.Parsec.Error as PE +import qualified Text.Parsec.Pos as PP + +-- | Generates a diagnostic from a 'PE.ParseError'. +diagnosticFromParseError + :: forall msg. (IsString msg, HasHints Void msg) + => (PE.ParseError -> Bool) -- ^ Determine whether the diagnostic is an error or a warning + -> msg -- ^ The main error of the diagnostic + -> Maybe [msg] -- ^ Default hints + -> PE.ParseError -- ^ The 'PE.ParseError' to transform into a 'Diagnostic' + -> Diagnostic msg +diagnosticFromParseError isError msg (fromMaybe [] -> defaultHints) error = + let pos = fromSourcePos $ PE.errorPos error + markers = toMarkers pos $ PE.errorMessages error + report = (msg & if isError error then err else warn) markers (defaultHints <> hints (undefined :: Void)) + in addReport def report + where + fromSourcePos :: PP.SourcePos -> Position + fromSourcePos pos = + let start = both fromIntegral (PP.sourceLine pos, PP.sourceColumn pos) + end = second (+ 1) start + in Position start end (PP.sourceName pos) + + toMarkers :: Position -> [PE.Message] -> [(Position, Marker msg)] + toMarkers source [] = [ (source, This $ fromString "<>") ] + toMarkers source msgs = + let putTogether [] = ([], [], [], []) + putTogether (PE.SysUnExpect thing:ms) = let (a, b, c, d) = putTogether ms in (thing:a, b, c, d) + putTogether (PE.UnExpect thing:ms) = let (a, b, c, d) = putTogether ms in (a, thing:b, c, d) + putTogether (PE.Expect thing:ms) = let (a, b, c, d) = putTogether ms in (a, b, thing:c, d) + putTogether (PE.Message thing:ms) = let (a, b, c, d) = putTogether ms in (a, b, c, thing:d) + + (sysUnexpectedList, unexpectedList, expectedList, messages) = putTogether msgs + in [ (source, marker) | unexpected <- if null unexpectedList then sysUnexpectedList else unexpectedList + , let marker = This $ fromString $ "unexpected " <> unexpected ] + <> [ (source, marker) | msg <- messages + , let marker = This $ fromString msg ] + <> [ (source, Where $ fromString $ "expected any of " <> intercalate ", " expectedList) ] + +-- | Generates an error diagnostic from a 'PE.ParseError'. +errorDiagnosticFromParseError + :: forall msg. (IsString msg, HasHints Void msg) + => msg -- ^ The main error message of the diagnostic + -> Maybe [msg] -- ^ Default hints + -> PE.ParseError -- ^ The 'PE.ParseError' to convert + -> Diagnostic msg +errorDiagnosticFromParseError = diagnosticFromParseError (const True) + +-- | Generates a warning diagnostic from a 'PE.ParseError'. +warningDiagnosticFromParseError + :: forall msg. (IsString msg, HasHints Void msg) + => msg -- ^ The main error message of the diagnostic + -> Maybe [msg] -- ^ Default hints + -> PE.ParseError -- ^ The 'PE.ParseError' to convert + -> Diagnostic msg +warningDiagnosticFromParseError = diagnosticFromParseError (const False) + + + +------------------------------------ +------------ INTERNAL -------------- +------------------------------------ + +-- | Applies a computation to both element of a tuple. +-- +-- > both f = bimap @(,) f f +both :: (a -> b) -> (a, a) -> (b, b) +both f ~(x, y) = (f x, f y) + diff --git a/test/parsec/Spec.hs b/test/parsec/Spec.hs new file mode 100644 index 0000000..8e61de6 --- /dev/null +++ b/test/parsec/Spec.hs @@ -0,0 +1,38 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} + +{-# OPTIONS -Wno-orphans #-} + +import Data.Bifunctor (first) +import Data.Text (Text) +import qualified Data.Text as Text (unpack) +import Data.Void (Void) + +import Error.Diagnose +import Error.Diagnose.Compat.Parsec + +import qualified Text.Parsec as P + +instance HasHints Void msg where + hints _ = mempty + +main :: IO () +main = do + let filename :: FilePath = "" + content1 :: Text = "0000000123456" + content2 :: Text = "00000a2223266" + + let res1 = first (errorDiagnosticFromParseError "Parse error on input" Nothing) $ P.parse (P.many1 P.digit <* P.eof) filename content1 + res2 = first (errorDiagnosticFromParseError "Parse error on input" Nothing) $ P.parse (P.many1 P.digit <* P.eof) filename content2 + + case res1 of + Left diag -> printDiagnostic stdout True True (addFile diag filename (Text.unpack content1) :: Diagnostic String) + Right res -> print res + case res2 of + Left diag -> printDiagnostic stdout True True (addFile diag filename (Text.unpack content2) :: Diagnostic String) + Right res -> print res +