{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedLabels #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeApplications #-}
{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}

{-# HLINT ignore "Use <$>" #-}

-- | 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 qualified Data.ByteString.Char8 as B
import Data.Char hiding (isDigit)
import Data.List.NonEmpty
import DotParse.FlatParse.TH hiding (merge)
import FlatParse.Basic hiding (cut, lines)
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 :: Parser Error a -> ByteString -> IO ()
testParser Parser Error a
p ByteString
b =
  case Parser Error a -> ByteString -> Result Error a
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 (ByteString -> IO ()) -> ByteString -> IO ()
forall a b. (a -> b) -> a -> b
$ ByteString -> Error -> ByteString
prettyError ByteString
b Error
e
    OK a
a ByteString
_ -> a -> IO ()
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_ :: Parser Error a -> ByteString -> a
runParser_ Parser Error a
p ByteString
b = case Parser Error a -> ByteString -> Result Error a
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 -> [Char] -> a
forall a. HasCallStack => [Char] -> a
error ([Char] -> a) -> [Char] -> a
forall a b. (a -> b) -> a -> b
$ ByteString -> [Char]
unpackUTF8 (ByteString -> [Char]) -> ByteString -> [Char]
forall a b. (a -> b) -> a -> b
$ ByteString
"leftovers: " ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
x
  Result Error a
Fail -> [Char] -> a
forall a. HasCallStack => [Char] -> a
error [Char]
"Fail"
  Err Error
e -> [Char] -> a
forall a. HasCallStack => [Char] -> a
error ([Char] -> a) -> [Char] -> a
forall a b. (a -> b) -> a -> b
$ ByteString -> [Char]
unpackUTF8 (ByteString -> [Char]) -> ByteString -> [Char]
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 Int -> Int -> Int
forall a. Num a => a -> a -> a
- Char -> Int
ord Char
'0') (Char -> Int) -> Parser Error Char -> Parser Error Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Char -> Bool) -> Parser Error Char
forall e. (Char -> Bool) -> Parser e Char
satisfyASCII Char -> Bool
isDigit

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

digits :: Parser Error (Int, Int)
digits :: Parser Error (Int, Int)
digits = (Int -> (Int, Int) -> (Int, Int))
-> Parser Error Int
-> Parser Error (Int, Int)
-> Parser Error (Int, Int)
forall a b e.
(a -> b -> b) -> Parser e a -> Parser e b -> Parser e b
chainr (\Int
n (!Int
place, !Int
acc) -> (Int
place Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
10, Int
acc Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
place Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
n)) Parser Error Int
digit ((Int, Int) -> Parser Error (Int, Int)
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 = Parser Error Double -> Parser Error Double
forall e a. Parser e a -> Parser e a
token do
  (Int
placel, Int
nl) <- Parser Error (Int, Int)
digits
  Parser Error (Int, Int)
-> ((Int, Int) -> Parser Error Double)
-> Parser Error Double
-> Parser Error Double
forall e a b.
Parser e a -> (a -> Parser e b) -> Parser e b -> Parser e b
optioned
    ($(char '.') Parser Error ()
-> Parser Error (Int, Int) -> Parser Error (Int, Int)
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) -> Parser Error Double
forall e a. Parser e a
empty
          (Int, Int)
_ -> Double -> Parser Error Double
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Double -> Parser Error Double) -> Double -> Parser Error Double
forall a b. (a -> b) -> a -> b
$ Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
nl Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
nr Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
placer
    )
    ( case Int
placel of
        Int
1 -> Parser Error Double
forall e a. Parser e a
empty
        Int
_ -> Double -> Parser Error Double
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Double -> Parser Error Double) -> Double -> Parser Error Double
forall a b. (a -> b) -> a -> b
$ Int -> Double
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 :: Parser e b -> Parser e b
signed Parser e b
p = Parser e () -> (() -> Parser e b) -> Parser e b -> Parser e b
forall e a b.
Parser e a -> (a -> Parser e b) -> Parser e b -> Parser e b
optioned $(char '-') (Parser e b -> () -> Parser e b
forall a b. a -> b -> a
const (((-b
1) b -> b -> b
forall a. Num a => a -> a -> a
*) (b -> b) -> Parser e b -> Parser e b
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 (packUTF8 "\"hello\"")
-- OK "hello" ""
--
-- >>> runParser quoted (packUTF8 "\"hello/\"\"")
-- OK "hello\"" ""
quoted :: Parser Error String
quoted :: Parser Error [Char]
quoted =
  $(symbol "\"") Parser Error () -> Parser Error [Char] -> Parser Error [Char]
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser Error Char -> Parser Error [Char]
forall e a. Parser e a -> Parser e [a]
many Parser Error Char
unquoteQuote Parser Error [Char] -> Parser Error () -> Parser Error [Char]
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 <- (Char -> Bool) -> Parser Error Char
forall e. (Char -> Bool) -> Parser e Char
satisfy (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'"')
  case Char
next of
    Char
'/' -> Parser Error ()
-> Parser Error Char -> Parser Error Char -> Parser Error Char
forall e a b. Parser e a -> Parser e b -> Parser e b -> Parser e b
branch (Parser Error () -> Parser Error ()
forall e a. Parser e a -> Parser e a
lookahead $(char '"')) (Char
'"' Char -> Parser Error () -> Parser Error Char
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ $(char '"')) (Char -> Parser Error Char
forall (f :: * -> *) a. Applicative f => a -> f a
pure Char
'/')
    Char
x -> Char -> Parser Error Char
forall (f :: * -> *) a. Applicative f => a -> f a
pure Char
x

-- | optional separators
sepP :: Parser e ()
sepP :: Parser e ()
sepP =
  Parser e () -> Parser e ()
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 :: Parser Error a -> Parser Error a
wrapSquareP Parser Error a
p =
  $(symbol "[") Parser Error () -> Parser Error a -> Parser Error a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser Error a
p Parser Error a -> Parser Error () -> Parser Error a
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
"[" ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
b ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
"]"

-- | print wrapping quotes
wrapQuotePrint :: ByteString -> ByteString
wrapQuotePrint :: ByteString -> ByteString
wrapQuotePrint ByteString
b = ByteString
"\"" ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
b ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
"\""

-- | parse wrapping square brackets
wrapCurlyP :: Parser Error a -> Parser Error a
wrapCurlyP :: Parser Error a -> Parser Error a
wrapCurlyP Parser Error a
p = $(symbol "{") Parser Error () -> Parser Error a -> Parser Error a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser Error a
p Parser Error a -> Parser Error () -> Parser Error a
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
"{" ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
b ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
"}"

-- | comma separated Point
pointP :: Parser Error (Point Double)
pointP :: Parser Error (Point Double)
pointP = Parser Error (Point Double) -> Parser Error (Point Double)
forall e a. Parser e a -> Parser e a
token (Parser Error (Point Double) -> Parser Error (Point Double))
-> Parser Error (Point Double) -> Parser Error (Point Double)
forall a b. (a -> b) -> a -> b
$ Double -> Double -> Point Double
forall a. a -> a -> Point a
Point (Double -> Double -> Point Double)
-> Parser Error Double -> Parser Error (Double -> Point Double)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Error Double
double Parser Error (Double -> Point Double)
-> Parser Error Double -> Parser Error (Point Double)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ($(symbol ",") Parser Error () -> Parser Error Double -> Parser Error Double
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
(Spline -> Spline -> Bool)
-> (Spline -> Spline -> Bool) -> Eq Spline
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]
(Int -> Spline -> ShowS)
-> (Spline -> [Char]) -> ([Spline] -> ShowS) -> Show Spline
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. Spline -> Rep Spline x)
-> (forall x. Rep Spline x -> Spline) -> Generic Spline
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
    (Maybe (Point Double)
 -> Maybe (Point Double)
 -> Point Double
 -> [(Point Double, Point Double, Point Double)]
 -> Spline)
-> Parser Error (Maybe (Point Double))
-> Parser
     Error
     (Maybe (Point Double)
      -> Point Double
      -> [(Point Double, Point Double, Point Double)]
      -> Spline)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Error (Point Double) -> Parser Error (Maybe (Point Double))
forall e a. Parser e a -> Parser e (Maybe a)
optional ($(symbol "e,") Parser Error ()
-> Parser Error (Point Double) -> Parser Error (Point Double)
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser Error (Point Double)
pointP)
    Parser
  Error
  (Maybe (Point Double)
   -> Point Double
   -> [(Point Double, Point Double, Point Double)]
   -> Spline)
-> Parser Error (Maybe (Point Double))
-> Parser
     Error
     (Point Double
      -> [(Point Double, Point Double, Point Double)] -> Spline)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser Error (Point Double) -> Parser Error (Maybe (Point Double))
forall e a. Parser e a -> Parser e (Maybe a)
optional ($(symbol "s") Parser Error ()
-> Parser Error (Point Double) -> Parser Error (Point Double)
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser Error (Point Double)
pointP)
    Parser
  Error
  (Point Double
   -> [(Point Double, Point Double, Point Double)] -> Spline)
-> Parser Error (Point Double)
-> Parser
     Error ([(Point Double, Point Double, Point Double)] -> Spline)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser Error (Point Double)
pointP
    Parser
  Error ([(Point Double, Point Double, Point Double)] -> Spline)
-> Parser Error [(Point Double, Point Double, Point Double)]
-> Parser Error Spline
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser Error (Point Double, Point Double, Point Double)
-> Parser Error [(Point Double, Point Double, Point Double)]
forall e a. Parser e a -> Parser e [a]
some ((,,) (Point Double
 -> Point Double
 -> Point Double
 -> (Point Double, Point Double, Point Double))
-> Parser Error (Point Double)
-> Parser
     Error
     (Point Double
      -> Point Double -> (Point Double, Point Double, Point Double))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Error (Point Double)
pointP Parser
  Error
  (Point Double
   -> Point Double -> (Point Double, Point Double, Point Double))
-> Parser Error (Point Double)
-> Parser
     Error (Point Double -> (Point Double, Point Double, Point Double))
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser Error (Point Double)
pointP Parser
  Error (Point Double -> (Point Double, Point Double, Point Double))
-> Parser Error (Point Double)
-> Parser Error (Point Double, Point Double, Point Double)
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 = Parser Error (Rect Double) -> Parser Error (Rect Double)
forall e a. Parser e a -> Parser e a
token (Parser Error (Rect Double) -> Parser Error (Rect Double))
-> Parser Error (Rect Double) -> Parser Error (Rect Double)
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
  Rect Double -> Parser Error (Rect Double)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Rect Double -> Parser Error (Rect Double))
-> Rect Double -> Parser Error (Rect Double)
forall a b. (a -> b) -> a -> b
$ Double -> Double -> Double -> Double -> Rect Double
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 Bool -> Parser Error () -> Parser Error Bool
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ $(symbol "true"))
    Parser Error Bool -> Parser Error Bool -> Parser Error Bool
forall e a. Parser e a -> Parser e a -> Parser e a
<|> (Bool
False Bool -> Parser Error () -> Parser Error Bool
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 :: Parser e a -> Parser e () -> Parser e (NonEmpty a)
nonEmptyP Parser e a
p Parser e ()
sep = Parser e (NonEmpty a) -> Parser e (NonEmpty a)
forall e a. Parser e a -> Parser e a
token (Parser e (NonEmpty a) -> Parser e (NonEmpty a))
-> Parser e (NonEmpty a) -> Parser e (NonEmpty a)
forall a b. (a -> b) -> a -> b
$ do
  a
s <- Parser e a
p
  [a]
xs <- Parser e a -> Parser e [a]
forall e a. Parser e a -> Parser e [a]
many (Parser e () -> Parser e (Maybe ())
forall e a. Parser e a -> Parser e (Maybe a)
optional Parser e ()
sep Parser e (Maybe ()) -> Parser e a -> Parser e a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser e a
p)
  NonEmpty a -> Parser e (NonEmpty a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (a
s a -> [a] -> NonEmpty a
forall a. a -> [a] -> NonEmpty a
:| [a]
xs)