{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedLabels #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TemplateHaskell #-}

-- | Lower-level flatparse parsers
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)

-- $setup
-- >>> import DotParse
-- >>> import FlatParse.Basic

-- | Run parser, print pretty error on failure.
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"

-- | run a Parser, erroring on leftovers, Fail or Err
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

-- * parsing

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

-- | (unsigned) Int parser
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))

-- |
-- >>> 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 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
    )

-- |
-- >>> 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 = 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

-- | Looks ahead for a "/"" that may be in the quoted string.
-- >>> runParser quoted (strToUtf8 "\"hello\"")
-- OK "hello" ""
--
-- >>> runParser quoted (strToUtf8 "\"hello/\"\"")
-- OK "hello\"" ""
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

-- | optional separators
sepP :: Parser e ()
sepP :: forall e. Parser e ()
sepP =
  forall e a. Parser e a -> Parser e a
token
    $( switch
         [|
           case _ of
             ";" -> pure ()
             "," -> pure ()
           |]
     )

-- | parse wrapping square brackets
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' "]")

-- | print wrapping square brackets
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
"]"

-- | print wrapping quotes
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
"\""

-- | parse wrapping square brackets
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' "}")

-- | print wrapping curly brackets
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
"}"

-- | comma separated Point
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)

-- | dot specification of a cubic spline (and an arrow head which is ignored here)
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)

-- |
-- http://www.graphviz.org/docs/attr-types/splineType/
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)

-- | comma separated rectangle or bounding box
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

-- | true | false
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"))

-- | NonEmpty version of many
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)