{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedLabels #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TemplateHaskell #-}
{-# OPTIONS_GHC -Wno-name-shadowing #-}
{-# OPTIONS_GHC -Wno-x-partial #-}

-- | TH stage restriction guff for flatparsing
module DotParse.FlatParse.TH where

import Data.ByteString hiding (head, length, reverse)
import Data.ByteString.Char8 qualified as B
import Data.Char hiding (isDigit)
import Data.Functor
import FlatParse.Basic
import Language.Haskell.TH

-- | Consume whitespace.
ws :: Parser e ()
ws :: forall e. Parser e ()
ws =
  $( switch
       [|
         case _ of
           -- order matters
           " " -> ws
           "\\\n" -> ws
           "\\\\\\n" -> ws
           "\n" -> ws
           "\t" -> ws
           "\r" -> ws
           ";" -> ws
           "//" -> lineComment
           "/*" -> multilineComment
           _ -> pure ()
         |]
   )

-- | Consume whitespace after running a parser.
token :: Parser e a -> Parser e a
token :: forall e a. Parser e a -> Parser e a
token Parser e a
p = Parser e a
p forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* forall e. Parser e ()
ws
{-# INLINE token #-}

-- | Parse a line comment.
lineComment :: Parser e ()
lineComment :: forall e. Parser e ()
lineComment =
  forall (st :: ZeroBitType) e a r.
ParserT st e a
-> (a -> ParserT st e r) -> ParserT st e r -> ParserT st e r
withOption
    forall (st :: ZeroBitType) e. ParserT st e Word8
anyWord8
    ( \case
        Word8
10 -> forall e. Parser e ()
ws
        Word8
_ -> forall e. Parser e ()
lineComment
    )
    (forall (f :: * -> *) a. Applicative f => a -> f a
pure ())

-- | Parse a potentially nested multiline comment.
multilineComment :: Parser e ()
multilineComment :: forall e. Parser e ()
multilineComment = forall {a} {e}. (Eq a, Num a) => a -> ParserT PureMode e ()
go (Int
1 :: Int)
  where
    go :: a -> ParserT PureMode e ()
go a
0 = forall e. Parser e ()
ws
    go a
n =
      $( switch
           [|
             case _ of
               "*/" -> go (n - 1)
               "/*" -> go (n + 1)
               _ -> branch anyWord8 (go n) (pure ())
             |]
       )

-- | Parse a HTML-Like string by counting the angle brackets
htmlLike :: Parser e String
htmlLike :: forall e. Parser e String
htmlLike = forall e. Parser e ()
ws forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> $(char '<') forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall {t} {e}.
(Eq t, Num t) =>
t -> String -> ParserT PureMode e String
go (Int
1 :: Int) String
"<"
  where
    go :: t -> String -> ParserT PureMode e String
go t
0 String
acc = forall e. Parser e ()
ws forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> forall a. [a] -> [a]
reverse String
acc
    go t
n String
acc =
      ($(char '>') forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> t -> String -> ParserT PureMode e String
go (t
n forall a. Num a => a -> a -> a
- t
1) (Char
'>' forall a. a -> [a] -> [a]
: String
acc))
        forall (st :: ZeroBitType) e a.
ParserT st e a -> ParserT st e a -> ParserT st e a
<|> ($(char '<') forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> t -> String -> ParserT PureMode e String
go (t
n forall a. Num a => a -> a -> a
+ t
1) (Char
'<' forall a. a -> [a] -> [a]
: String
acc))
        forall (st :: ZeroBitType) e a.
ParserT st e a -> ParserT st e a -> ParserT st e a
<|> (forall (st :: ZeroBitType) e. ParserT st e Char
anyChar forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (\Char
c -> t -> String -> ParserT PureMode e String
go t
n (Char
c forall a. a -> [a] -> [a]
: String
acc)))

-- | First character of a dot identifier.
isValidStartChar :: Char -> Bool
isValidStartChar :: Char -> Bool
isValidStartChar Char
c =
  Char -> Bool
isAsciiUpper Char
c
    Bool -> Bool -> Bool
|| Char -> Bool
isAsciiLower Char
c
    Bool -> Bool -> Bool
|| (Char
'\200' forall a. Ord a => a -> a -> Bool
<= Char
c Bool -> Bool -> Bool
&& Char
c forall a. Ord a => a -> a -> Bool
<= Char
'\377')
    Bool -> Bool -> Bool
|| (Char
c forall a. Eq a => a -> a -> Bool
== Char
'_')

-- | character of a dot identifier.
isValidChar :: Char -> Bool
isValidChar :: Char -> Bool
isValidChar Char
c = Char -> Bool
isValidStartChar Char
c Bool -> Bool -> Bool
|| Char -> Bool
isDigit Char
c

-- | Read a starting character of an identifier.
identStartChar :: Parser e Char
identStartChar :: forall e. Parser e Char
identStartChar = forall (st :: ZeroBitType) e. (Char -> Bool) -> ParserT st e Char
satisfy Char -> Bool
isValidStartChar

-- | Read a non-starting character of an identifier.
identChar :: Parser e Char
identChar :: forall e. Parser e Char
identChar = forall (st :: ZeroBitType) e. (Char -> Bool) -> ParserT st e Char
satisfy Char -> Bool
isValidChar

-- | Parse a non-keyword string.
symbol :: String -> Q Exp
symbol :: String -> Q Exp
symbol String
str = [|token $(string str)|]

-- | Parse a keyword string.
keyword :: String -> Q Exp
keyword :: String -> Q Exp
keyword String
str = [|token ($(string str) `notFollowedBy` identChar)|]

-- | Parser a non-keyword string, throw precise error on failure.
symbol' :: String -> Q Exp
symbol' :: String -> Q Exp
symbol' String
str = [|$(symbol str) `cut'` strToUtf8 str|]

-- | Parse a keyword string, throw precise error on failure.
keyword' :: String -> Q Exp
keyword' :: String -> Q Exp
keyword' String
str = [|$(keyword str) `cut'` strToUtf8 str|]

-- | Parse an identifier.
ident :: Parser e ByteString
ident :: forall e. Parser e ByteString
ident =
  forall e a. Parser e a -> Parser e a
token forall a b. (a -> b) -> a -> b
$
    forall (st :: ZeroBitType) e a.
ParserT st e a -> ParserT st e ByteString
byteStringOf forall a b. (a -> b) -> a -> b
$
      forall e. Parser e Char
identStartChar forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall (st :: ZeroBitType) e a. ParserT st e a -> ParserT st e ()
skipMany forall e. Parser e Char
identChar

-- | Parse an identifier, throw a precise error on failure.
ident' :: Parser Error ByteString
ident' :: Parser Error ByteString
ident' = forall e. Parser e ByteString
ident forall a. Parser Error a -> ByteString -> Parser Error a
`cut'` ByteString
"identifier"

-- | A parsing error.
data Error
  = -- | A precisely known error, like leaving out "in" from "let".
    Precise Pos ByteString
  | -- | An imprecise error, when we expect a number of different things,
    --   but parse something else.
    Imprecise Pos [ByteString]
  deriving (Error -> Error -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Error -> Error -> Bool
$c/= :: Error -> Error -> Bool
== :: Error -> Error -> Bool
$c== :: Error -> Error -> Bool
Eq, 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)

-- | position of error
errorPos :: Error -> Pos
errorPos :: Error -> Pos
errorPos (Precise Pos
p ByteString
_) = Pos
p
errorPos (Imprecise Pos
p [ByteString]
_) = 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
_ [ByteString]
es, Imprecise Pos
_ [ByteString]
es') -> Pos -> [ByteString] -> Error
Imprecise Pos
p ([ByteString]
es forall a. Semigroup a => a -> a -> a
<> [ByteString]
es')
{-# NOINLINE merge #-} -- merge is "cold" code, so we shouldn't inline it.

-- | Pretty print an error. The `ByteString` input is the source file. The offending line from the
--   source is displayed in the output.
prettyError :: ByteString -> Error -> ByteString
prettyError :: ByteString -> Error -> ByteString
prettyError ByteString
b Error
e =
  let pos :: Pos
      pos :: Pos
pos = case Error
e of
        Imprecise Pos
pos [ByteString]
_ -> Pos
pos
        Precise Pos
pos ByteString
_ -> Pos
pos
      ls :: [ByteString]
ls = ByteString -> [ByteString]
B.lines 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 :: ByteString
line = if Int
l forall a. Ord a => a -> a -> Bool
< forall (t :: * -> *) a. Foldable t => t a -> Int
length [ByteString]
ls then [ByteString]
ls forall a. [a] -> Int -> a
!! Int
l else ByteString
""
      linum :: ByteString
linum = String -> ByteString
strToUtf8 forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show Int
l
      lpad :: ByteString
lpad = Int -> Char -> ByteString
B.replicate (ByteString -> Int
B.length ByteString
linum) Char
' '

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

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

-- | Imprecise cut: we slap a list of items on inner errors.
cut :: Parser Error a -> [ByteString] -> Parser Error a
cut :: forall a. Parser Error a -> [ByteString] -> Parser Error a
cut Parser Error a
p [ByteString]
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 -> [ByteString] -> Error
Imprecise Pos
pos [ByteString]
es) Error -> Error -> Error
merge

-- | Precise cut: we propagate at most a single error.
cut' :: Parser Error a -> ByteString -> Parser Error a
cut' :: forall a. Parser Error a -> ByteString -> Parser Error a
cut' Parser Error a
p ByteString
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 -> ByteString -> Error
Precise Pos
pos ByteString
e) Error -> Error -> Error
merge