mirror of
https://github.com/Mesabloo/diagnose.git
synced 2024-10-26 11:18:47 +03:00
parsec: create compatibility layer
This commit is contained in:
parent
04b9499612
commit
e898e06ba7
@ -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
|
||||
|
20
package.yaml
20
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
|
||||
|
||||
|
92
src/Error/Diagnose/Compat/Parsec.hs
Normal file
92
src/Error/Diagnose/Compat/Parsec.hs
Normal file
@ -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 "<<unknown error>>") ]
|
||||
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)
|
||||
|
38
test/parsec/Spec.hs
Normal file
38
test/parsec/Spec.hs
Normal file
@ -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 = "<interactive>"
|
||||
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
|
||||
|
Loading…
Reference in New Issue
Block a user