parsec: create compatibility layer

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

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
+

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 "<<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)
+

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 = "<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
+