{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedLabels #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TemplateHaskell #-}
{-# OPTIONS_GHC -Wno-name-shadowing #-}
{-# OPTIONS_GHC -Wno-x-partial #-}
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
ws :: Parser e ()
ws :: forall e. Parser e ()
ws =
$( switch
[|
case _ of
" " -> ws
"\\\n" -> ws
"\\\\\\n" -> ws
"\n" -> ws
"\t" -> ws
"\r" -> ws
";" -> ws
"//" -> lineComment
"/*" -> multilineComment
_ -> pure ()
|]
)
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 #-}
lineComment :: Parser e ()
=
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 ())
multilineComment :: Parser e ()
= 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 ())
|]
)
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)))
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
'_')
isValidChar :: Char -> Bool
isValidChar :: Char -> Bool
isValidChar Char
c = Char -> Bool
isValidStartChar Char
c Bool -> Bool -> Bool
|| Char -> Bool
isDigit Char
c
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
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
symbol :: String -> Q Exp
symbol :: String -> Q Exp
symbol String
str = [|token $(string str)|]
keyword :: String -> Q Exp
keyword :: String -> Q Exp
keyword String
str = [|token ($(string str) `notFollowedBy` identChar)|]
symbol' :: String -> Q Exp
symbol' :: String -> Q Exp
symbol' String
str = [|$(symbol str) `cut'` strToUtf8 str|]
keyword' :: String -> Q Exp
keyword' :: String -> Q Exp
keyword' String
str = [|$(keyword str) `cut'` strToUtf8 str|]
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
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"
data Error
=
Precise Pos ByteString
|
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)
errorPos :: Error -> Pos
errorPos :: Error -> Pos
errorPos (Precise Pos
p ByteString
_) = Pos
p
errorPos (Imprecise Pos
p [ByteString]
_) = Pos
p
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 #-}
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
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
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