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

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

-- |
-- Module      : Error.Diagnose.Compat.Parsec
-- Description : Compatibility layer for parsec
-- Copyright   : (c) Mesabloo, 2021
-- 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.Function ((&))
import Data.List (intercalate)
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) ->
  -- | The main error of the diagnostic
  msg ->
  -- | Default hints
  Maybe [msg] ->
  -- | The 'PE.ParseError' to transform into a 'Diagnostic'
  PE.ParseError ->
  Diagnostic msg
diagnosticFromParseError :: (ParseError -> Bool)
-> msg -> Maybe [msg] -> ParseError -> Diagnostic msg
diagnosticFromParseError ParseError -> Bool
isError msg
msg ([msg] -> Maybe [msg] -> [msg]
forall a. a -> Maybe a -> a
fromMaybe [] -> [msg]
defaultHints) ParseError
error =
  let pos :: Position
pos = SourcePos -> Position
fromSourcePos (SourcePos -> Position) -> SourcePos -> Position
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 ([Message] -> [(Position, Marker msg)])
-> [Message] -> [(Position, Marker msg)]
forall a b. (a -> b) -> a -> b
$ ParseError -> [Message]
PE.errorMessages ParseError
error
      report :: Report msg
report = (msg
msg msg
-> (msg -> [(Position, Marker msg)] -> [msg] -> Report msg)
-> [(Position, Marker msg)]
-> [msg]
-> Report msg
forall a b. a -> (a -> b) -> b
& if ParseError -> Bool
isError ParseError
error then msg -> [(Position, Marker msg)] -> [msg] -> Report msg
forall msg. msg -> [(Position, Marker msg)] -> [msg] -> Report msg
err else msg -> [(Position, Marker msg)] -> [msg] -> Report msg
forall msg. msg -> [(Position, Marker msg)] -> [msg] -> Report msg
warn) [(Position, Marker msg)]
markers ([msg]
defaultHints [msg] -> [msg] -> [msg]
forall a. Semigroup a => a -> a -> a
<> Void -> [msg]
forall e msg. HasHints e msg => e -> [msg]
hints (Void
forall a. HasCallStack => a
undefined :: Void))
   in Diagnostic msg -> Report msg -> Diagnostic msg
forall msg. Diagnostic msg -> Report msg -> Diagnostic msg
addReport Diagnostic msg
forall a. Default a => a
def Report msg
report
  where
    fromSourcePos :: PP.SourcePos -> Position
    fromSourcePos :: SourcePos -> Position
fromSourcePos SourcePos
pos =
      let start :: (Int, Int)
start = (Int -> Int) -> (Int, Int) -> (Int, Int)
forall a b. (a -> b) -> (a, a) -> (b, b)
both Int -> Int
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 = (Int -> Int) -> (Int, Int) -> (Int, Int)
forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second (Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) (Int, Int)
start
       in (Int, Int) -> (Int, Int) -> FilePath -> Position
Position (Int, Int)
start (Int, Int)
end (SourcePos -> FilePath
PP.sourceName SourcePos
pos)

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

          ([FilePath]
sysUnexpectedList, [FilePath]
unexpectedList, [FilePath]
expectedList, [FilePath]
messages) = [Message] -> ([FilePath], [FilePath], [FilePath], [FilePath])
putTogether [Message]
msgs
       in [ (Position
source, Marker msg
marker) | FilePath
unexpected <- if [FilePath] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [FilePath]
unexpectedList then [FilePath]
sysUnexpectedList else [FilePath]
unexpectedList, let marker :: Marker msg
marker = msg -> Marker msg
forall msg. msg -> Marker msg
This (msg -> Marker msg) -> msg -> Marker msg
forall a b. (a -> b) -> a -> b
$ FilePath -> msg
forall a. IsString a => FilePath -> a
fromString (FilePath -> msg) -> FilePath -> msg
forall a b. (a -> b) -> a -> b
$ FilePath
"unexpected " FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
unexpected
          ]
            [(Position, Marker msg)]
-> [(Position, Marker msg)] -> [(Position, Marker msg)]
forall a. Semigroup a => a -> a -> a
<> [ (Position
source, Marker msg
marker) | FilePath
msg <- [FilePath]
messages, let marker :: Marker msg
marker = msg -> Marker msg
forall msg. msg -> Marker msg
This (msg -> Marker msg) -> msg -> Marker msg
forall a b. (a -> b) -> a -> b
$ FilePath -> msg
forall a. IsString a => FilePath -> a
fromString FilePath
msg
               ]
            [(Position, Marker msg)]
-> [(Position, Marker msg)] -> [(Position, Marker msg)]
forall a. Semigroup a => a -> a -> a
<> [(Position
source, msg -> Marker msg
forall msg. msg -> Marker msg
Where (msg -> Marker msg) -> msg -> Marker msg
forall a b. (a -> b) -> a -> b
$ FilePath -> msg
forall a. IsString a => FilePath -> a
fromString (FilePath -> msg) -> FilePath -> msg
forall a b. (a -> b) -> a -> b
$ FilePath
"expecting any of " FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath -> [FilePath] -> FilePath
forall a. [a] -> [[a]] -> [a]
intercalate FilePath
", " [FilePath]
expectedList)]

-- | Generates an error diagnostic from a 'PE.ParseError'.
errorDiagnosticFromParseError ::
  forall msg.
  (IsString msg, HasHints Void msg) =>
  -- | The main error message of the diagnostic
  msg ->
  -- | Default hints
  Maybe [msg] ->
  -- | The 'PE.ParseError' to convert
  PE.ParseError ->
  Diagnostic msg
errorDiagnosticFromParseError :: msg -> Maybe [msg] -> ParseError -> Diagnostic msg
errorDiagnosticFromParseError = (ParseError -> Bool)
-> msg -> Maybe [msg] -> ParseError -> Diagnostic msg
forall msg.
(IsString msg, HasHints Void msg) =>
(ParseError -> Bool)
-> msg -> Maybe [msg] -> ParseError -> Diagnostic msg
diagnosticFromParseError (Bool -> ParseError -> Bool
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) =>
  -- | The main error message of the diagnostic
  msg ->
  -- | Default hints
  Maybe [msg] ->
  -- | The 'PE.ParseError' to convert
  PE.ParseError ->
  Diagnostic msg
warningDiagnosticFromParseError :: msg -> Maybe [msg] -> ParseError -> Diagnostic msg
warningDiagnosticFromParseError = (ParseError -> Bool)
-> msg -> Maybe [msg] -> ParseError -> Diagnostic msg
forall msg.
(IsString msg, HasHints Void msg) =>
(ParseError -> Bool)
-> msg -> Maybe [msg] -> ParseError -> Diagnostic msg
diagnosticFromParseError (Bool -> ParseError -> Bool
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 :: (a -> b) -> (a, a) -> (b, b)
both a -> b
f ~(a
x, a
y) = (a -> b
f a
x, a -> b
f a
y)