{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE ViewPatterns #-}

{-# OPTIONS -Wno-name-shadowing #-}

-- |
-- Module      : Error.Diagnose.Compat.Parsec
-- Description : Compatibility layer for parsec
-- Copyright   : (c) Mesabloo, 2021-2022
-- License     : BSD3
-- Stability   : experimental
-- Portability : Portable
module Error.Diagnose.Compat.Parsec
  ( diagnosticFromParseError,
    errorDiagnosticFromParseError,
    warningDiagnosticFromParseError,
    module Error.Diagnose.Compat.Hints,
  )
where

import Data.Bifunctor (second)
import Data.List (intercalate, nub)
import Data.Maybe (fromMaybe)
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) =>
  -- | Determine whether the diagnostic is an error or a warning
  (PE.ParseError -> Bool) ->
  -- | An optional error code
  Maybe msg ->
  -- | The main error of the diagnostic
  msg ->
  -- | Default hints
  Maybe [Note msg] ->
  -- | The 'PE.ParseError' to transform into a 'Diagnostic'
  PE.ParseError ->
  Diagnostic msg
diagnosticFromParseError :: forall msg.
(IsString msg, HasHints Void msg) =>
(ParseError -> Bool)
-> Maybe msg
-> msg
-> Maybe [Note msg]
-> ParseError
-> Diagnostic msg
diagnosticFromParseError ParseError -> Bool
isError Maybe msg
code msg
msg (forall a. a -> Maybe a -> a
fromMaybe [] -> [Note msg]
defaultHints) ParseError
error =
  let pos :: Position
pos = SourcePos -> Position
fromSourcePos forall a b. (a -> b) -> a -> b
$ ParseError -> SourcePos
PE.errorPos ParseError
error
      markers :: [(Position, Marker msg)]
markers = Position -> [Message] -> [(Position, Marker msg)]
toMarkers Position
pos forall a b. (a -> b) -> a -> b
$ ParseError -> [Message]
PE.errorMessages ParseError
error
      report :: Report msg
report = (if ParseError -> Bool
isError ParseError
error then forall msg.
Maybe msg
-> msg -> [(Position, Marker msg)] -> [Note msg] -> Report msg
Err Maybe msg
code msg
msg else forall msg.
Maybe msg
-> msg -> [(Position, Marker msg)] -> [Note msg] -> Report msg
Warn Maybe msg
code msg
msg) [(Position, Marker msg)]
markers ([Note msg]
defaultHints forall a. Semigroup a => a -> a -> a
<> forall e msg. HasHints e msg => e -> [Note msg]
hints (forall a. HasCallStack => a
undefined :: Void))
   in forall msg. Diagnostic msg -> Report msg -> Diagnostic msg
addReport forall a. Monoid a => a
mempty Report msg
report
  where
    fromSourcePos :: PP.SourcePos -> Position
    fromSourcePos :: SourcePos -> Position
fromSourcePos SourcePos
pos =
      let start :: (Int, Int)
start = forall a b. (a -> b) -> (a, a) -> (b, b)
both forall a b. (Integral a, Num b) => a -> b
fromIntegral (SourcePos -> Int
PP.sourceLine SourcePos
pos, SourcePos -> Int
PP.sourceColumn SourcePos
pos)
          end :: (Int, Int)
end = forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second (forall a. Num a => a -> a -> a
+ Int
1) (Int, Int)
start
       in (Int, Int) -> (Int, Int) -> String -> Position
Position (Int, Int)
start (Int, Int)
end (SourcePos -> String
PP.sourceName SourcePos
pos)

    toMarkers :: Position -> [PE.Message] -> [(Position, Marker msg)]
    toMarkers :: Position -> [Message] -> [(Position, Marker msg)]
toMarkers Position
source [] = [(Position
source, forall msg. msg -> Marker msg
This forall a b. (a -> b) -> a -> b
$ forall a. IsString a => String -> a
fromString String
"<<unknown error>>")]
    toMarkers Position
source [Message]
msgs =
      let putTogether :: [Message] -> ([String], [String], [String], [String])
putTogether [] = ([], [], [], [])
          putTogether (PE.SysUnExpect String
thing : [Message]
ms) = let ([String]
a, [String]
b, [String]
c, [String]
d) = [Message] -> ([String], [String], [String], [String])
putTogether [Message]
ms in (String
thing forall a. a -> [a] -> [a]
: [String]
a, [String]
b, [String]
c, [String]
d)
          putTogether (PE.UnExpect String
thing : [Message]
ms) = let ([String]
a, [String]
b, [String]
c, [String]
d) = [Message] -> ([String], [String], [String], [String])
putTogether [Message]
ms in ([String]
a, String
thing forall a. a -> [a] -> [a]
: [String]
b, [String]
c, [String]
d)
          putTogether (PE.Expect String
thing : [Message]
ms) = let ([String]
a, [String]
b, [String]
c, [String]
d) = [Message] -> ([String], [String], [String], [String])
putTogether [Message]
ms in ([String]
a, [String]
b, String
thing forall a. a -> [a] -> [a]
: [String]
c, [String]
d)
          putTogether (PE.Message String
thing : [Message]
ms) = let ([String]
a, [String]
b, [String]
c, [String]
d) = [Message] -> ([String], [String], [String], [String])
putTogether [Message]
ms in ([String]
a, [String]
b, [String]
c, String
thing forall a. a -> [a] -> [a]
: [String]
d)

          (forall a. Eq a => [a] -> [a]
nub -> [String]
sysUnexpectedList, forall a. Eq a => [a] -> [a]
nub -> [String]
unexpectedList, forall a. Eq a => [a] -> [a]
nub -> [String]
expectedList, forall a. Eq a => [a] -> [a]
nub -> [String]
messages) = [Message] -> ([String], [String], [String], [String])
putTogether [Message]
msgs

          firstSysUnexpectedMessage :: String
firstSysUnexpectedMessage = forall a. [a] -> a
head [String]
sysUnexpectedList
          unexpectedMessage :: String
unexpectedMessage = String
"unexpected " forall a. Semigroup a => a -> a -> a
<> if forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
unexpectedList then if forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
firstSysUnexpectedMessage then String
"end of line" else String
firstSysUnexpectedMessage else forall a. [a] -> [[a]] -> [a]
intercalate String
", " (forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => t a -> Bool
null) [String]
unexpectedList)
       in [ (Position
source, forall msg. msg -> Marker msg
This forall a b. (a -> b) -> a -> b
$ forall a. IsString a => String -> a
fromString String
unexpectedMessage) ]
            forall a. Semigroup a => a -> a -> a
<> [ (Position
source, forall msg. msg -> Marker msg
This forall a b. (a -> b) -> a -> b
$ forall a. IsString a => String -> a
fromString String
msg) | String
msg <- [String]
messages ]
            forall a. Semigroup a => a -> a -> a
<> [ (Position
source, forall msg. msg -> Marker msg
Where forall a b. (a -> b) -> a -> b
$ forall a. IsString a => String -> a
fromString forall a b. (a -> b) -> a -> b
$ String
"expecting any of " forall a. Semigroup a => a -> a -> a
<> forall a. [a] -> [[a]] -> [a]
intercalate String
", " (forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => t a -> Bool
null) [String]
expectedList)) ]

-- | Generates an error diagnostic from a 'PE.ParseError'.
errorDiagnosticFromParseError ::
  forall msg.
  (IsString msg, HasHints Void msg) =>
  -- | An optional error code
  Maybe msg ->
  -- | The main error message of the diagnostic
  msg ->
  -- | Default hints
  Maybe [Note msg] ->
  -- | The 'PE.ParseError' to convert
  PE.ParseError ->
  Diagnostic msg
errorDiagnosticFromParseError :: forall msg.
(IsString msg, HasHints Void msg) =>
Maybe msg
-> msg -> Maybe [Note msg] -> ParseError -> Diagnostic msg
errorDiagnosticFromParseError = forall msg.
(IsString msg, HasHints Void msg) =>
(ParseError -> Bool)
-> Maybe msg
-> msg
-> Maybe [Note msg]
-> ParseError
-> Diagnostic msg
diagnosticFromParseError (forall a b. a -> b -> a
const Bool
True)

-- | Generates a warning diagnostic from a 'PE.ParseError'.
warningDiagnosticFromParseError ::
  forall msg.
  (IsString msg, HasHints Void msg) =>
  -- | An optional error code
  Maybe msg ->
  -- | The main error message of the diagnostic
  msg ->
  -- | Default hints
  Maybe [Note msg] ->
  -- | The 'PE.ParseError' to convert
  PE.ParseError ->
  Diagnostic msg
warningDiagnosticFromParseError :: forall msg.
(IsString msg, HasHints Void msg) =>
Maybe msg
-> msg -> Maybe [Note msg] -> ParseError -> Diagnostic msg
warningDiagnosticFromParseError = forall msg.
(IsString msg, HasHints Void msg) =>
(ParseError -> Bool)
-> Maybe msg
-> msg
-> Maybe [Note msg]
-> ParseError
-> Diagnostic msg
diagnosticFromParseError (forall a b. a -> b -> a
const Bool
False)

------------------------------------
------------ INTERNAL --------------
------------------------------------

-- | Applies a computation to both element of a tuple.
--
--   > both f = bimap @(,) f f
both :: (a -> b) -> (a, a) -> (b, b)
both :: forall a b. (a -> b) -> (a, a) -> (b, b)
both a -> b
f ~(a
x, a
y) = (a -> b
f a
x, a -> b
f a
y)