{-# LANGUAGE OverloadedStrings #-}

-- | Parse an SVG ellipse, as seen in the <line>, <circle> or <ellipse> element, e.g.
--
-- LINE x1=0 y1=80 x2=100 y2=20
-- CIRCLE cx=100 cy=50 r=100
-- ELLIPSE cx=100 cy=50 rx=100 ry=50
module Geometry.SvgParser.SimpleShapes (parse, SimpleShape(..)) where



import           Data.Foldable
import           Data.Text            (Text)
import qualified Data.Text            as T
import qualified Text.Megaparsec      as MP
import qualified Text.Megaparsec.Char as MPC

import Geometry.Core
import Geometry.SvgParser.Common




data SimpleShape
    = SvgLine Line
    | SvgCircle Circle
    | SvgEllipse Ellipse
    deriving Int -> SimpleShape -> ShowS
[SimpleShape] -> ShowS
SimpleShape -> String
(Int -> SimpleShape -> ShowS)
-> (SimpleShape -> String)
-> ([SimpleShape] -> ShowS)
-> Show SimpleShape
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> SimpleShape -> ShowS
showsPrec :: Int -> SimpleShape -> ShowS
$cshow :: SimpleShape -> String
show :: SimpleShape -> String
$cshowList :: [SimpleShape] -> ShowS
showList :: [SimpleShape] -> ShowS
Show

parse :: Text -> Either Text SimpleShape
parse :: Text -> Either Text SimpleShape
parse Text
input = case Parsec Text Text SimpleShape
-> String
-> Text
-> Either (ParseErrorBundle Text Text) SimpleShape
forall e s a.
Parsec e s a -> String -> s -> Either (ParseErrorBundle s e) a
MP.parse (ParsecT Text Text Identity ()
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m ()
MPC.space ParsecT Text Text Identity ()
-> Parsec Text Text SimpleShape -> Parsec Text Text SimpleShape
forall a b.
ParsecT Text Text Identity a
-> ParsecT Text Text Identity b -> ParsecT Text Text Identity b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parsec Text Text SimpleShape
parseSimpleShape Parsec Text Text SimpleShape
-> ParsecT Text Text Identity () -> Parsec Text Text SimpleShape
forall a b.
ParsecT Text Text Identity a
-> ParsecT Text Text Identity b -> ParsecT Text Text Identity a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* ParsecT Text Text Identity ()
forall e s (m :: * -> *). MonadParsec e s m => m ()
MP.eof) String
sourceFile Text
input of
    Left ParseErrorBundle Text Text
errBundle -> Text -> Either Text SimpleShape
forall a b. a -> Either a b
Left (String -> Text
T.pack (ParseErrorBundle Text Text -> String
forall s e.
(VisualStream s, TraversableStream s, ShowErrorComponent e) =>
ParseErrorBundle s e -> String
MP.errorBundlePretty ParseErrorBundle Text Text
errBundle))
    Right SimpleShape
shape -> SimpleShape -> Either Text SimpleShape
forall a b. b -> Either a b
Right SimpleShape
shape
  where
    sourceFile :: String
sourceFile = String
""

parseSimpleShape :: MP.Parsec Text Text SimpleShape
parseSimpleShape :: Parsec Text Text SimpleShape
parseSimpleShape = [Parsec Text Text SimpleShape] -> Parsec Text Text SimpleShape
forall (t :: * -> *) (f :: * -> *) a.
(Foldable t, Alternative f) =>
t (f a) -> f a
asum
    [ Line -> SimpleShape
SvgLine (Line -> SimpleShape)
-> ParsecT Text Text Identity Line -> Parsec Text Text SimpleShape
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT Text Text Identity Line
parseLine
    , Circle -> SimpleShape
SvgCircle (Circle -> SimpleShape)
-> ParsecT Text Text Identity Circle
-> Parsec Text Text SimpleShape
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT Text Text Identity Circle
parseCircle
    , Ellipse -> SimpleShape
SvgEllipse (Ellipse -> SimpleShape)
-> ParsecT Text Text Identity Ellipse
-> Parsec Text Text SimpleShape
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT Text Text Identity Ellipse
parseEllipse
    ]

parseLine :: MP.Parsec Text Text Line
parseLine :: ParsecT Text Text Identity Line
parseLine = String
-> ParsecT Text Text Identity Line
-> ParsecT Text Text Identity Line
forall a.
String
-> ParsecT Text Text Identity a -> ParsecT Text Text Identity a
forall e s (m :: * -> *) a.
MonadParsec e s m =>
String -> m a -> m a
MP.label String
"line (x1,y1,x2,y2)" (ParsecT Text Text Identity Line
 -> ParsecT Text Text Identity Line)
-> ParsecT Text Text Identity Line
-> ParsecT Text Text Identity Line
forall a b. (a -> b) -> a -> b
$ do
    Tokens Text
_ <- Parsec Text Text (Tokens Text) -> Parsec Text Text (Tokens Text)
forall err a. Ord err => Parsec err Text a -> Parsec err Text a
lexeme (Tokens Text -> Parsec Text Text (Tokens Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
MPC.string Tokens Text
"LINE")
    Double
x1 <- Text -> Parsec Text Text Double
assignedValue Text
"x1"
    Double
y1 <- Text -> Parsec Text Text Double
assignedValue Text
"y1"
    Double
x2 <- Text -> Parsec Text Text Double
assignedValue Text
"x2"
    Double
y2 <- Text -> Parsec Text Text Double
assignedValue Text
"y2"
    Line -> ParsecT Text Text Identity Line
forall a. a -> ParsecT Text Text Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Vec2 -> Vec2 -> Line
Line (Double -> Double -> Vec2
Vec2 Double
x1 Double
y1) (Double -> Double -> Vec2
Vec2 Double
x2 Double
y2))

parseCircle :: MP.Parsec Text Text Circle
parseCircle :: ParsecT Text Text Identity Circle
parseCircle = String
-> ParsecT Text Text Identity Circle
-> ParsecT Text Text Identity Circle
forall a.
String
-> ParsecT Text Text Identity a -> ParsecT Text Text Identity a
forall e s (m :: * -> *) a.
MonadParsec e s m =>
String -> m a -> m a
MP.label String
"circle (cx,cy,r)" (ParsecT Text Text Identity Circle
 -> ParsecT Text Text Identity Circle)
-> ParsecT Text Text Identity Circle
-> ParsecT Text Text Identity Circle
forall a b. (a -> b) -> a -> b
$ do
    Tokens Text
_ <- Parsec Text Text (Tokens Text) -> Parsec Text Text (Tokens Text)
forall err a. Ord err => Parsec err Text a -> Parsec err Text a
lexeme (Tokens Text -> Parsec Text Text (Tokens Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
MPC.string Tokens Text
"CIRCLE")
    Double
cx <- Text -> Parsec Text Text Double
assignedValue Text
"cx"
    Double
cy <- Text -> Parsec Text Text Double
assignedValue Text
"cy"
    Double
r <- Text -> Parsec Text Text Double
assignedValue Text
"r"
    Circle -> ParsecT Text Text Identity Circle
forall a. a -> ParsecT Text Text Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Vec2 -> Double -> Circle
Circle (Double -> Double -> Vec2
Vec2 Double
cx Double
cy) Double
r)

parseEllipse :: MP.Parsec Text Text Ellipse
parseEllipse :: ParsecT Text Text Identity Ellipse
parseEllipse = String
-> ParsecT Text Text Identity Ellipse
-> ParsecT Text Text Identity Ellipse
forall a.
String
-> ParsecT Text Text Identity a -> ParsecT Text Text Identity a
forall e s (m :: * -> *) a.
MonadParsec e s m =>
String -> m a -> m a
MP.label String
"ellipse (cx,cy,rx,ry)" (ParsecT Text Text Identity Ellipse
 -> ParsecT Text Text Identity Ellipse)
-> ParsecT Text Text Identity Ellipse
-> ParsecT Text Text Identity Ellipse
forall a b. (a -> b) -> a -> b
$ do
    Tokens Text
_ <- Parsec Text Text (Tokens Text) -> Parsec Text Text (Tokens Text)
forall err a. Ord err => Parsec err Text a -> Parsec err Text a
lexeme (Tokens Text -> Parsec Text Text (Tokens Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
MPC.string Tokens Text
"ELLIPSE")
    Double
cx <- Text -> Parsec Text Text Double
assignedValue Text
"cx"
    Double
cy <- Text -> Parsec Text Text Double
assignedValue Text
"cy"
    Double
rx <- Text -> Parsec Text Text Double
assignedValue Text
"rx"
    Double
ry <- Text -> Parsec Text Text Double
assignedValue Text
"ry"
    Ellipse -> ParsecT Text Text Identity Ellipse
forall a. a -> ParsecT Text Text Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Transformation -> Ellipse
Ellipse (Vec2 -> Transformation
translate (Double -> Double -> Vec2
Vec2 Double
cx Double
cy) Transformation -> Transformation -> Transformation
forall a. Semigroup a => a -> a -> a
<> Double -> Double -> Transformation
scale' Double
rx Double
ry))

assignedValue :: Text -> MP.Parsec Text Text Double
assignedValue :: Text -> Parsec Text Text Double
assignedValue Text
name = do
    Tokens Text
_ <- Tokens Text -> Parsec Text Text (Tokens Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
MPC.string Text
Tokens Text
name
    Char -> ParsecT Text Text Identity ()
forall err. Ord err => Char -> Parsec err Text ()
char_ Char
'='
    Parsec Text Text Double
forall err. Ord err => Parsec err Text Double
double