{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedLabels #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TemplateHaskell #-}
module DotParse.FlatParse
( Error (..),
prettyError,
keyword,
keyword',
symbol,
symbol',
ws,
token,
ident,
cut,
cut',
testParser,
runParser_,
int,
double,
signed,
quoted,
htmlLike,
sepP,
wrapSquareP,
wrapSquarePrint,
wrapCurlyP,
wrapCurlyPrint,
wrapQuotePrint,
pointP,
Spline (..),
splineP,
rectP,
boolP,
nonEmptyP,
)
where
import Data.Bool
import Data.ByteString hiding (empty, head, length, map, zip, zipWith)
import Data.ByteString.Char8 qualified as B
import Data.Char hiding (isDigit)
import Data.List.NonEmpty
import DotParse.FlatParse.TH hiding (merge)
import FlatParse.Basic hiding (cut)
import GHC.Generics
import NumHask.Space
import Prelude hiding (replicate)
testParser :: (Show a) => Parser Error a -> ByteString -> IO ()
testParser :: forall a. Show a => Parser Error a -> ByteString -> IO ()
testParser Parser Error a
p ByteString
b =
case forall e a. Parser e a -> ByteString -> Result e a
runParser Parser Error a
p ByteString
b of
Err Error
e -> ByteString -> IO ()
B.putStrLn forall a b. (a -> b) -> a -> b
$ ByteString -> Error -> ByteString
prettyError ByteString
b Error
e
OK a
a ByteString
_ -> forall a. Show a => a -> IO ()
print a
a
Result Error a
Fail -> ByteString -> IO ()
B.putStrLn ByteString
"uncaught parse error"
runParser_ :: Parser Error a -> ByteString -> a
runParser_ :: forall a. Parser Error a -> ByteString -> a
runParser_ Parser Error a
p ByteString
b = case forall e a. Parser e a -> ByteString -> Result e a
runParser Parser Error a
p ByteString
b of
OK a
r ByteString
"" -> a
r
OK a
_ ByteString
x -> forall a. HasCallStack => [Char] -> a
error forall a b. (a -> b) -> a -> b
$ ByteString -> [Char]
utf8ToStr forall a b. (a -> b) -> a -> b
$ ByteString
"leftovers: " forall a. Semigroup a => a -> a -> a
<> ByteString
x
Result Error a
Fail -> forall a. HasCallStack => [Char] -> a
error [Char]
"Fail"
Err Error
e -> forall a. HasCallStack => [Char] -> a
error forall a b. (a -> b) -> a -> b
$ ByteString -> [Char]
utf8ToStr forall a b. (a -> b) -> a -> b
$ ByteString -> Error -> ByteString
prettyError ByteString
b Error
e
digit :: Parser Error Int
digit :: Parser Error 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
int :: Parser Error Int
int :: Parser Error Int
int = forall e a. Parser e a -> Parser e a
token 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)) Parser Error 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 Error (Int, Int)
digits :: Parser Error (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)) Parser Error Int
digit (forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int
1, Int
0))
double :: Parser Error Double
double :: Parser Error Double
double = forall e a. Parser e a -> Parser e a
token do
(Int
placel, Int
nl) <- Parser Error (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
*> Parser Error (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
)
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 = 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 a b. a -> b -> a
const (((-b
1) *) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser e b
p)) Parser e b
p
quoted :: Parser Error String
quoted :: Parser Error [Char]
quoted =
$(symbol "\"") forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall (f :: * -> *) a. Alternative f => f a -> f [a]
many Parser Error Char
unquoteQuote forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* $(symbol' "\"")
unquoteQuote :: Parser Error Char
unquoteQuote :: Parser Error Char
unquoteQuote = do
Char
next <- forall (st :: ZeroBitType) e. (Char -> Bool) -> ParserT st e Char
satisfy (forall a. Eq a => a -> a -> Bool
/= Char
'"')
case Char
next of
Char
'/' -> forall (st :: ZeroBitType) e a b.
ParserT st e a
-> ParserT st e b -> ParserT st e b -> ParserT st e b
branch (forall (st :: ZeroBitType) e a. ParserT st e a -> ParserT st e a
lookahead $(char '"')) (Char
'"' forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ $(char '"')) (forall (f :: * -> *) a. Applicative f => a -> f a
pure Char
'/')
Char
x -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Char
x
sepP :: Parser e ()
sepP :: forall e. Parser e ()
sepP =
forall e a. Parser e a -> Parser e a
token
$( switch
[|
case _ of
";" -> pure ()
"," -> pure ()
|]
)
wrapSquareP :: Parser Error a -> Parser Error a
wrapSquareP :: forall a. Parser Error a -> Parser Error a
wrapSquareP Parser Error a
p =
$(symbol "[") forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser Error a
p forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* $(symbol' "]")
wrapSquarePrint :: ByteString -> ByteString
wrapSquarePrint :: ByteString -> ByteString
wrapSquarePrint ByteString
b = ByteString
"[" forall a. Semigroup a => a -> a -> a
<> ByteString
b forall a. Semigroup a => a -> a -> a
<> ByteString
"]"
wrapQuotePrint :: ByteString -> ByteString
wrapQuotePrint :: ByteString -> ByteString
wrapQuotePrint ByteString
b = ByteString
"\"" forall a. Semigroup a => a -> a -> a
<> ByteString
b forall a. Semigroup a => a -> a -> a
<> ByteString
"\""
wrapCurlyP :: Parser Error a -> Parser Error a
wrapCurlyP :: forall a. Parser Error a -> Parser Error a
wrapCurlyP Parser Error a
p = $(symbol "{") forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser Error a
p forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* $(symbol' "}")
wrapCurlyPrint :: ByteString -> ByteString
wrapCurlyPrint :: ByteString -> ByteString
wrapCurlyPrint ByteString
b = ByteString
"{" forall a. Semigroup a => a -> a -> a
<> ByteString
b forall a. Semigroup a => a -> a -> a
<> ByteString
"}"
pointP :: Parser Error (Point Double)
pointP :: Parser Error (Point Double)
pointP = forall e a. Parser e a -> Parser e a
token forall a b. (a -> b) -> a -> b
$ forall a. a -> a -> Point a
Point forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Error Double
double forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ($(symbol ",") forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser Error Double
double)
data Spline = Spline {Spline -> Maybe (Point Double)
splineEnd :: Maybe (Point Double), Spline -> Maybe (Point Double)
splineStart :: Maybe (Point Double), Spline -> Point Double
splineP1 :: Point Double, Spline -> [(Point Double, Point Double, Point Double)]
splineTriples :: [(Point Double, Point Double, Point Double)]} deriving (Spline -> Spline -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Spline -> Spline -> Bool
$c/= :: Spline -> Spline -> Bool
== :: Spline -> Spline -> Bool
$c== :: Spline -> Spline -> Bool
Eq, Int -> Spline -> ShowS
[Spline] -> ShowS
Spline -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [Spline] -> ShowS
$cshowList :: [Spline] -> ShowS
show :: Spline -> [Char]
$cshow :: Spline -> [Char]
showsPrec :: Int -> Spline -> ShowS
$cshowsPrec :: Int -> Spline -> ShowS
Show, forall x. Rep Spline x -> Spline
forall x. Spline -> Rep Spline x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep Spline x -> Spline
$cfrom :: forall x. Spline -> Rep Spline x
Generic)
splineP :: Parser Error Spline
splineP :: Parser Error Spline
splineP =
Maybe (Point Double)
-> Maybe (Point Double)
-> Point Double
-> [(Point Double, Point Double, Point Double)]
-> Spline
Spline
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (st :: ZeroBitType) e a.
ParserT st e a -> ParserT st e (Maybe a)
optional ($(symbol "e,") forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser Error (Point Double)
pointP)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (st :: ZeroBitType) e a.
ParserT st e a -> ParserT st e (Maybe a)
optional ($(symbol "s") forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser Error (Point Double)
pointP)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser Error (Point Double)
pointP
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (f :: * -> *) a. Alternative f => f a -> f [a]
some ((,,) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Error (Point Double)
pointP forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser Error (Point Double)
pointP forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser Error (Point Double)
pointP)
rectP :: Parser Error (Rect Double)
rectP :: Parser Error (Rect Double)
rectP = forall e a. Parser e a -> Parser e a
token forall a b. (a -> b) -> a -> b
$ do
Double
x <- Parser Error Double
double
()
_ <- $(symbol ",")
Double
y <- Parser Error Double
double
()
_ <- $(symbol ",")
Double
z <- Parser Error Double
double
()
_ <- $(symbol ",")
Double
w <- Parser Error Double
double
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. a -> a -> a -> a -> Rect a
Rect Double
x Double
z Double
y Double
w
boolP :: Parser Error Bool
boolP :: Parser Error Bool
boolP =
(Bool
True forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ $(symbol "true"))
forall (st :: ZeroBitType) e a.
ParserT st e a -> ParserT st e a -> ParserT st e a
<|> (Bool
False forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ $(symbol "false"))
nonEmptyP :: Parser e a -> Parser e () -> Parser e (NonEmpty a)
nonEmptyP :: forall e a. Parser e a -> Parser e () -> Parser e (NonEmpty a)
nonEmptyP Parser e a
p Parser e ()
sep = forall e a. Parser e a -> Parser e a
token forall a b. (a -> b) -> a -> b
$ do
a
s <- Parser e a
p
[a]
xs <- forall (f :: * -> *) a. Alternative f => f a -> f [a]
many (forall (st :: ZeroBitType) e a.
ParserT st e a -> ParserT st e (Maybe a)
optional Parser e ()
sep forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser e a
p)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (a
s forall a. a -> [a] -> NonEmpty a
:| [a]
xs)