{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedLabels #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeApplications #-}
{-# OPTIONS_GHC -Wno-name-shadowing #-}

-- | Lower-level flatparse parsers
module Chart.FlatParse
  ( runParserMaybe,
    runParserEither,
    testParser,
    Expected (..),
    Error (..),
    prettyError,
    cut,
    cut',
    ws,
    ws_,
    wss,
    sep,
    bracketed,
    wrapped,
    digit,
    int,
    double,
    signed,
  )
where

import Data.Bool
import Data.ByteString (ByteString)
import Data.Char hiding (isDigit)
import Data.List (replicate)
import FlatParse.Basic hiding (cut)
import GHC.Exts
import Prelude hiding (replicate)

-- $setup
-- >>> :set -XTemplateHaskell
-- >>> import Chart.FlatParse
-- >>> import FlatParse.Basic

-- * parser error model

--
-- taken from flatparse examples

-- | An expected item which is displayed in error messages.
data Expected
  = -- | An error message.
    Msg String
  | -- | A literal expected thing.
    Lit String
  deriving (Expected -> Expected -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Expected -> Expected -> Bool
$c/= :: Expected -> Expected -> Bool
== :: Expected -> Expected -> Bool
$c== :: Expected -> Expected -> Bool
Eq, Int -> Expected -> ShowS
[Expected] -> ShowS
Expected -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Expected] -> ShowS
$cshowList :: [Expected] -> ShowS
show :: Expected -> String
$cshow :: Expected -> String
showsPrec :: Int -> Expected -> ShowS
$cshowsPrec :: Int -> Expected -> ShowS
Show, Eq Expected
Expected -> Expected -> Bool
Expected -> Expected -> Ordering
Expected -> Expected -> Expected
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: Expected -> Expected -> Expected
$cmin :: Expected -> Expected -> Expected
max :: Expected -> Expected -> Expected
$cmax :: Expected -> Expected -> Expected
>= :: Expected -> Expected -> Bool
$c>= :: Expected -> Expected -> Bool
> :: Expected -> Expected -> Bool
$c> :: Expected -> Expected -> Bool
<= :: Expected -> Expected -> Bool
$c<= :: Expected -> Expected -> Bool
< :: Expected -> Expected -> Bool
$c< :: Expected -> Expected -> Bool
compare :: Expected -> Expected -> Ordering
$ccompare :: Expected -> Expected -> Ordering
Ord)

instance IsString Expected where fromString :: String -> Expected
fromString = String -> Expected
Lit

-- | A parsing error.
data Error
  = -- | A precisely known error, like leaving out "in" from "let".
    Precise Pos Expected
  | -- | An imprecise error, when we expect a number of different things,
    --   but parse something else.
    Imprecise Pos [Expected]
  deriving (Int -> Error -> ShowS
[Error] -> ShowS
Error -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Error] -> ShowS
$cshowList :: [Error] -> ShowS
show :: Error -> String
$cshow :: Error -> String
showsPrec :: Int -> Error -> ShowS
$cshowsPrec :: Int -> Error -> ShowS
Show)

errorPos :: Error -> Pos
errorPos :: Error -> Pos
errorPos (Precise Pos
p Expected
_) = Pos
p
errorPos (Imprecise Pos
p [Expected]
_) = Pos
p

-- | Merge two errors. Inner errors (which were thrown at points with more consumed inputs)
--   are preferred. If errors are thrown at identical input positions, we prefer precise errors
--   to imprecise ones.
--
--   The point of prioritizing inner and precise errors is to suppress the deluge of "expected"
--   items, and instead try to point to a concrete issue to fix.
merge :: Error -> Error -> Error
merge :: Error -> Error -> Error
merge Error
e Error
e' = case (Error -> Pos
errorPos Error
e, Error -> Pos
errorPos Error
e') of
  (Pos
p, Pos
p') | Pos
p forall a. Ord a => a -> a -> Bool
< Pos
p' -> Error
e'
  (Pos
p, Pos
p') | Pos
p forall a. Ord a => a -> a -> Bool
> Pos
p' -> Error
e
  (Pos
p, Pos
_) -> case (Error
e, Error
e') of
    (Precise {}, Error
_) -> Error
e
    (Error
_, Precise {}) -> Error
e'
    (Imprecise Pos
_ [Expected]
es, Imprecise Pos
_ [Expected]
es') -> Pos -> [Expected] -> Error
Imprecise Pos
p ([Expected]
es forall a. Semigroup a => a -> a -> a
<> [Expected]
es')
{-# NOINLINE merge #-} -- merge is "cold" code, so we shouldn't inline it.

-- | Pretty print an error. The `B.ByteString` input is the source file. The offending line from the
--   source is displayed in the output.
prettyError :: ByteString -> Error -> String
prettyError :: ByteString -> Error -> String
prettyError ByteString
b Error
e =
  let pos :: Pos
      pos :: Pos
pos = case Error
e of
        Imprecise Pos
p [Expected]
_ -> Pos
p
        Precise Pos
p Expected
_ -> Pos
p
      ls :: [String]
ls = ByteString -> [String]
linesUtf8 ByteString
b
      (Int
l, Int
c) = forall a. [a] -> a
head forall a b. (a -> b) -> a -> b
$ ByteString -> [Pos] -> [(Int, Int)]
posLineCols ByteString
b [Pos
pos]
      line :: String
line = if Int
l forall a. Ord a => a -> a -> Bool
< forall (t :: * -> *) a. Foldable t => t a -> Int
length [String]
ls then [String]
ls forall a. [a] -> Int -> a
!! Int
l else String
""
      line' :: String
line' = if forall (t :: * -> *) a. Foldable t => t a -> Int
length String
line forall a. Ord a => a -> a -> Bool
> Int
300 then forall a. Int -> [a] -> [a]
Prelude.drop (Int
c forall a. Num a => a -> a -> a
- Int
50) forall a b. (a -> b) -> a -> b
$ forall a. Int -> [a] -> [a]
Prelude.take (Int
c forall a. Num a => a -> a -> a
+ Int
50) String
line else String
line
      linum :: String
linum = forall a. Show a => a -> String
show Int
l
      lpad :: String
lpad = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a b. a -> b -> a
const Char
' ') String
linum

      expected :: Expected -> String
expected (Lit String
s) = forall a. Show a => a -> String
show String
s
      expected (Msg String
s) = String
s

      err :: Error -> String
err (Precise Pos
_ Expected
e) = Expected -> String
expected Expected
e
      err (Imprecise Pos
_ [Expected]
es) = [Expected] -> String
imprec [Expected]
es

      imprec :: [Expected] -> String
      imprec :: [Expected] -> String
imprec [] = forall a. HasCallStack => String -> a
error String
"impossible"
      imprec [Expected
e] = Expected -> String
expected Expected
e
      imprec (Expected
e : [Expected]
es) = (Expected -> String
expected Expected
e forall a. Semigroup a => a -> a -> a
<> [Expected] -> String
go [Expected]
es)
        where
          go :: [Expected] -> String
go [] = String
""
          go [Expected
e] = (String
" or " forall a. Semigroup a => a -> a -> a
<> Expected -> String
expected Expected
e)
          go (Expected
e : [Expected]
es) = (String
", " forall a. Semigroup a => a -> a -> a
<> Expected -> String
expected Expected
e forall a. Semigroup a => a -> a -> a
<> [Expected] -> String
go [Expected]
es)
   in (forall a. Show a => a -> String
show Int
l forall a. Semigroup a => a -> a -> a
<> (String
":" forall a. Semigroup a => a -> a -> a
<> (forall a. Show a => a -> String
show Int
c forall a. Semigroup a => a -> a -> a
<> (String
":\n" forall a. Semigroup a => a -> a -> a
<> (String
lpad forall a. Semigroup a => a -> a -> a
<> (String
"|\n" forall a. Semigroup a => a -> a -> a
<> (String
linum forall a. Semigroup a => a -> a -> a
<> (String
"| " forall a. Semigroup a => a -> a -> a
<> (String
line' forall a. Semigroup a => a -> a -> a
<> (String
"\n" forall a. Semigroup a => a -> a -> a
<> (String
lpad forall a. Semigroup a => a -> a -> a
<> (String
"| " forall a. Semigroup a => a -> a -> a
<> (forall a. Int -> a -> [a]
replicate Int
c Char
' ' forall a. Semigroup a => a -> a -> a
<> (String
"^\n" forall a. Semigroup a => a -> a -> a
<> (String
"parse error: expected " forall a. Semigroup a => a -> a -> a
<> Error -> String
err Error
e)))))))))))))))

-- | Imprecise cut: we slap a list of items on inner errors.
cut :: Parser Error a -> [Expected] -> Parser Error a
cut :: forall a. Parser Error a -> [Expected] -> Parser Error a
cut Parser Error a
p [Expected]
es = do
  Pos
pos <- forall (st :: ZeroBitType) e. ParserT st e Pos
getPos
  forall (st :: ZeroBitType) e a.
ParserT st e a -> e -> (e -> e -> e) -> ParserT st e a
cutting Parser Error a
p (Pos -> [Expected] -> Error
Imprecise Pos
pos [Expected]
es) Error -> Error -> Error
merge

-- | Precise cut: we propagate at most a single error.
cut' :: Parser Error a -> Expected -> Parser Error a
cut' :: forall a. Parser Error a -> Expected -> Parser Error a
cut' Parser Error a
p Expected
e = do
  Pos
pos <- forall (st :: ZeroBitType) e. ParserT st e Pos
getPos
  forall (st :: ZeroBitType) e a.
ParserT st e a -> e -> (e -> e -> e) -> ParserT st e a
cutting Parser Error a
p (Pos -> Expected -> Error
Precise Pos
pos Expected
e) Error -> Error -> Error
merge

-- | run a Parser, Nothing on failure
runParserMaybe :: Parser e a -> ByteString -> Maybe a
runParserMaybe :: forall e a. Parser e a -> ByteString -> Maybe a
runParserMaybe Parser e a
p ByteString
b = case forall e a. Parser e a -> ByteString -> Result e a
runParser Parser e a
p ByteString
b of
  OK a
r ByteString
_ -> forall a. a -> Maybe a
Just a
r
  Result e a
Fail -> forall a. Maybe a
Nothing
  Err e
_ -> forall a. Maybe a
Nothing

-- | Run parser, Left error on failure.
runParserEither :: Parser Error a -> ByteString -> Either ByteString a
runParserEither :: forall a. Parser Error a -> ByteString -> Either ByteString a
runParserEither Parser Error a
p ByteString
bs = case forall e a. Parser e a -> ByteString -> Result e a
runParser Parser Error a
p ByteString
bs of
  Err Error
e -> forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ String -> ByteString
strToUtf8 forall a b. (a -> b) -> a -> b
$ ByteString -> Error -> String
prettyError ByteString
bs Error
e
  OK a
a ByteString
_ -> forall a b. b -> Either a b
Right a
a
  Result Error a
Fail -> forall a b. a -> Either a b
Left ByteString
"uncaught parse error"

-- | Run parser, print pretty error on failure.
testParser :: (Show a) => Parser Error a -> String -> IO ()
testParser :: forall a. Show a => Parser Error a -> String -> IO ()
testParser Parser Error a
p String
str = case forall a. IsString a => String -> a
fromString String
str of
  ByteString
b -> case forall e a. Parser e a -> ByteString -> Result e a
runParser Parser Error a
p ByteString
b of
    Err Error
e -> String -> IO ()
putStrLn forall a b. (a -> b) -> a -> b
$ ByteString -> Error -> String
prettyError ByteString
b Error
e
    OK a
a ByteString
_ -> forall a. Show a => a -> IO ()
print a
a
    Result Error a
Fail -> String -> IO ()
putStrLn String
"uncaught parse error"

-- * parsing

isWs :: Char -> Bool
isWs :: Char -> Bool
isWs Char
x =
  Char
x forall a. Eq a => a -> a -> Bool
== Char
' '
    Bool -> Bool -> Bool
|| Char
x forall a. Eq a => a -> a -> Bool
== Char
'\n'
    Bool -> Bool -> Bool
|| Char
x forall a. Eq a => a -> a -> Bool
== Char
'\t'
    Bool -> Bool -> Bool
|| Char
x forall a. Eq a => a -> a -> Bool
== Char
'\r'

-- | single whitespace
--
-- >>> runParser ws " \nx"
-- OK ' ' "\nx"
ws :: Parser e Char
ws :: forall e. Parser e Char
ws = forall (st :: ZeroBitType) e. (Char -> Bool) -> ParserT st e Char
satisfy Char -> Bool
isWs

-- | Consume whitespace.
--
-- >>> runParser ws_ " \nx"
-- OK () "x"
--
-- >>> runParser ws_ "x"
-- OK () "x"
ws_ :: Parser e ()
ws_ :: forall e. Parser e ()
ws_ =
  $( switch
       [|
         case _ of
           " " -> ws_
           "\n" -> ws_
           "\t" -> ws_
           "\r" -> ws_
           _ -> pure ()
         |]
   )

-- | multiple whitespace
--
-- >>> runParser wss " \nx"
-- OK " \n" "x"
--
-- >>> runParser wss "x"
-- Fail
wss :: Parser e ByteString
wss :: forall e. Parser e ByteString
wss = forall (st :: ZeroBitType) e a.
ParserT st e a -> ParserT st e ByteString
byteStringOf forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. Alternative f => f a -> f [a]
some forall e. Parser e Char
ws

-- | some with a separator
--
-- >>> runParser (sep ws (many (satisfy (/= ' ')))) "a b c"
-- OK ["a","b","c"] ""
sep :: Parser e s -> Parser e a -> Parser e [a]
sep :: forall e s a. Parser e s -> Parser e a -> Parser e [a]
sep Parser e s
s Parser e a
p = (:) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser e a
p forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (f :: * -> *) a. Alternative f => f a -> f [a]
many (Parser e s
s forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser e a
p)

-- | parser bracketed by two other parsers
--
-- >>> runParser (bracketed ($(char '[')) ($(char ']')) (many (satisfy (/= ']')))) "[bracketed]"
-- OK "bracketed" ""
bracketed :: Parser e b -> Parser e b -> Parser e a -> Parser e a
bracketed :: forall e b a. Parser e b -> Parser e b -> Parser e a -> Parser e a
bracketed Parser e b
o Parser e b
c Parser e a
p = Parser e b
o forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser e a
p forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser e b
c

-- | parser wrapped by another parser
--
-- >>> runParser (wrapped ($(char '"')) (many (satisfy (/= '"')))) "\"wrapped\""
-- OK "wrapped" ""
wrapped :: Parser e () -> Parser e a -> Parser e a
wrapped :: forall e a. Parser e () -> Parser e a -> Parser e a
wrapped Parser e ()
x Parser e a
p = forall e b a. Parser e b -> Parser e b -> Parser e a -> Parser e a
bracketed Parser e ()
x Parser e ()
x Parser e a
p

-- | A single digit
--
-- runParserMaybe digit "5"
-- Just 5
digit :: Parser e Int
digit :: forall e. Parser e Int
digit = (\Char
c -> Char -> Int
ord Char
c forall a. Num a => a -> a -> a
- Char -> Int
ord Char
'0') forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (st :: ZeroBitType) e. (Char -> Bool) -> ParserT st e Char
satisfyAscii Char -> Bool
isDigit

-- | (unsigned) Int parser
--
-- runParserMaybe int "567"
-- Just 567
int :: Parser e Int
int :: forall e. Parser e Int
int = do
  (Int
place, Int
n) <- forall a b (st :: ZeroBitType) e.
(a -> b -> b) -> ParserT st e a -> ParserT st e b -> ParserT st e b
chainr (\Int
n (!Int
place, !Int
acc) -> (Int
place forall a. Num a => a -> a -> a
* Int
10, Int
acc forall a. Num a => a -> a -> a
+ Int
place forall a. Num a => a -> a -> a
* Int
n)) forall e. Parser e Int
digit (forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int
1, Int
0))
  case Int
place of
    Int
1 -> forall (f :: * -> *) a. Alternative f => f a
empty
    Int
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Int
n

digits :: Parser e (Int, Int)
digits :: forall e. Parser e (Int, Int)
digits = forall a b (st :: ZeroBitType) e.
(a -> b -> b) -> ParserT st e a -> ParserT st e b -> ParserT st e b
chainr (\Int
n (!Int
place, !Int
acc) -> (Int
place forall a. Num a => a -> a -> a
* Int
10, Int
acc forall a. Num a => a -> a -> a
+ Int
place forall a. Num a => a -> a -> a
* Int
n)) forall e. Parser e Int
digit (forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int
1, Int
0))

-- |
-- >>> runParser double "1.234x"
-- OK 1.234 "x"
--
-- >>> runParser double "."
-- Fail
--
-- >>> runParser double "123"
-- OK 123.0 ""
--
-- >>> runParser double ".123"
-- OK 0.123 ""
--
-- >>> runParser double "123."
-- OK 123.0 ""
double :: Parser e Double
double :: forall e. Parser e Double
double = do
  (Int
placel, Int
nl) <- forall e. Parser e (Int, Int)
digits
  forall (st :: ZeroBitType) e a r.
ParserT st e a
-> (a -> ParserT st e r) -> ParserT st e r -> ParserT st e r
withOption
    ($(char '.') forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall e. Parser e (Int, Int)
digits)
    ( \(Int
placer, Int
nr) ->
        case (Int
placel, Int
placer) of
          (Int
1, Int
1) -> forall (f :: * -> *) a. Alternative f => f a
empty
          (Int, Int)
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
nl forall a. Num a => a -> a -> a
+ forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
nr forall a. Fractional a => a -> a -> a
/ forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
placer
    )
    ( case Int
placel of
        Int
1 -> forall (f :: * -> *) a. Alternative f => f a
empty
        Int
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
nl
    )

minus :: Parser e ()
minus :: forall e. Parser e ()
minus = $(char '-')

-- |
-- >>> runParser (signed double) "-1.234x"
-- OK (-1.234) "x"
signed :: (Num b) => Parser e b -> Parser e b
signed :: forall b e. Num b => Parser e b -> Parser e b
signed Parser e b
p = do
  Maybe ()
m <- forall (st :: ZeroBitType) e a.
ParserT st e a -> ParserT st e (Maybe a)
optional forall e. Parser e ()
minus
  case Maybe ()
m of
    Maybe ()
Nothing -> Parser e b
p
    Just () -> forall a. Num a => a -> a
negate forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser e b
p