{-# Language OverloadedStrings #-}
{-# Language DefaultSignatures #-}
--------------------------------------------------------------------------------
-- |
-- Module      :  Ipe.PathParser
-- Copyright   :  (C) Frank Staals
-- License     :  see the LICENSE file
-- Maintainer  :  Frank Staals
--
-- Parser for a 'Path' in Ipe.
--
--------------------------------------------------------------------------------
module Ipe.PathParser
  ( Coordinate(..)
  , readCoordinate, readPoint
  , readMatrix, readRectangle
  , runParser
  , readPathOperations

  , pOperation, pPoint, pCoordinate
  ) where

import           Data.Bifunctor
import           Data.Char (isSpace)
import           Data.Ext (ext)
import           Data.Functor (($>))
import           Data.Geometry.Box
import           Data.Geometry.Matrix
import           Data.Geometry.Point
import           Data.Geometry.Vector
import           Data.Ratio
import           Data.RealNumber.Rational
import           Data.Text (Text)
import qualified Data.Text as T
import           Ipe.ParserPrimitives
import           Ipe.Path (Operation(..))
import           Text.Parsec.Error (messageString, errorMessages)


-----------------------------------------------------------------------
-- | Represent stuff that can be used as a coordinate in ipe. (similar to show/read)

class Fractional r => Coordinate r where
    -- reads a coordinate. The input is an integer representing the
    -- part before the decimal point, and a length and an integer
    -- representing the part after the decimal point
    fromSeq :: Integer -> Maybe (Int, Integer) -> r
    default fromSeq :: (Ord r, Fractional r) => Integer -> Maybe (Int, Integer) -> r
    fromSeq = Integer -> Maybe (Int, Integer) -> r
forall r.
(Ord r, Fractional r) =>
Integer -> Maybe (Int, Integer) -> r
defaultFromSeq

defaultFromSeq                :: (Ord r, Fractional r)
                              => Integer -> Maybe (Int, Integer) -> r
defaultFromSeq :: Integer -> Maybe (Int, Integer) -> r
defaultFromSeq Integer
x Maybe (Int, Integer)
Nothing      = Integer -> r
forall a. Num a => Integer -> a
fromInteger Integer
x
defaultFromSeq Integer
x (Just (Int
l,Integer
y)) = let x' :: r
x'          = Integer -> r
forall a. Num a => Integer -> a
fromInteger Integer
x
                                    y' :: r
y'          = Integer -> r
forall a. Num a => Integer -> a
fromInteger Integer
y
                                    asDecimal :: r -> r
asDecimal r
a =  r
a r -> r -> r
forall a. Num a => a -> a -> a
* (r
0.1 r -> Int -> r
forall a b. (Num a, Integral b) => a -> b -> a
^ Int
l)
                                    z :: r
z           = if r
x' r -> r -> Bool
forall a. Ord a => a -> a -> Bool
< r
0 then (-r
1) else r
1
                                in r
z r -> r -> r
forall a. Num a => a -> a -> a
* (r -> r
forall a. Num a => a -> a
abs r
x' r -> r -> r
forall a. Num a => a -> a -> a
+ r -> r
asDecimal r
y')

instance Coordinate Double
instance Coordinate Float
instance Coordinate (Ratio Integer)
instance Coordinate (RealNumber p)

-----------------------------------------------------------------------
-- | Running the parsers

-- | Read/parse a single coordinate value.
readCoordinate :: Coordinate r => Text -> Either Text r
readCoordinate :: Text -> Either Text r
readCoordinate = Parser r -> Text -> Either Text r
forall a. Parser a -> Text -> Either Text a
runParser Parser r
forall r. Coordinate r => Parser r
pCoordinate

-- | Read/parse a single point
readPoint :: Coordinate r => Text -> Either Text (Point 2 r)
readPoint :: Text -> Either Text (Point 2 r)
readPoint = Parser (Point 2 r) -> Text -> Either Text (Point 2 r)
forall a. Parser a -> Text -> Either Text a
runParser Parser (Point 2 r)
forall r. Coordinate r => Parser (Point 2 r)
pPoint

-- | Run a parser
runParser   :: Parser a -> Text -> Either Text a
runParser :: Parser a -> Text -> Either Text a
runParser Parser a
p = (ParseError -> Text)
-> ((a, Text) -> a) -> Either ParseError (a, Text) -> Either Text a
forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap ParseError -> Text
errorText (a, Text) -> a
forall a b. (a, b) -> a
fst (Either ParseError (a, Text) -> Either Text a)
-> (Text -> Either ParseError (a, Text)) -> Text -> Either Text a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Parser a -> Text -> Either ParseError (a, Text)
forall a. Parser a -> Text -> Either ParseError (a, Text)
runP Parser a
p

-- Collect errors
data Either' l r = Left' l | Right' r deriving (Int -> Either' l r -> ShowS
[Either' l r] -> ShowS
Either' l r -> String
(Int -> Either' l r -> ShowS)
-> (Either' l r -> String)
-> ([Either' l r] -> ShowS)
-> Show (Either' l r)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall l r. (Show l, Show r) => Int -> Either' l r -> ShowS
forall l r. (Show l, Show r) => [Either' l r] -> ShowS
forall l r. (Show l, Show r) => Either' l r -> String
showList :: [Either' l r] -> ShowS
$cshowList :: forall l r. (Show l, Show r) => [Either' l r] -> ShowS
show :: Either' l r -> String
$cshow :: forall l r. (Show l, Show r) => Either' l r -> String
showsPrec :: Int -> Either' l r -> ShowS
$cshowsPrec :: forall l r. (Show l, Show r) => Int -> Either' l r -> ShowS
Show,Either' l r -> Either' l r -> Bool
(Either' l r -> Either' l r -> Bool)
-> (Either' l r -> Either' l r -> Bool) -> Eq (Either' l r)
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall l r. (Eq l, Eq r) => Either' l r -> Either' l r -> Bool
/= :: Either' l r -> Either' l r -> Bool
$c/= :: forall l r. (Eq l, Eq r) => Either' l r -> Either' l r -> Bool
== :: Either' l r -> Either' l r -> Bool
$c== :: forall l r. (Eq l, Eq r) => Either' l r -> Either' l r -> Bool
Eq)

instance (Semigroup l, Semigroup r) => Semigroup (Either' l r) where
  (Left' l
l)  <> :: Either' l r -> Either' l r -> Either' l r
<> (Left' l
l')  = l -> Either' l r
forall l r. l -> Either' l r
Left' (l -> Either' l r) -> l -> Either' l r
forall a b. (a -> b) -> a -> b
$ l
l l -> l -> l
forall a. Semigroup a => a -> a -> a
<> l
l'
  (Left' l
l)  <> Either' l r
_           = l -> Either' l r
forall l r. l -> Either' l r
Left' l
l
  Either' l r
_          <> (Left' l
l')  = l -> Either' l r
forall l r. l -> Either' l r
Left' l
l'
  (Right' r
r) <> (Right' r
r') = r -> Either' l r
forall l r. r -> Either' l r
Right' (r -> Either' l r) -> r -> Either' l r
forall a b. (a -> b) -> a -> b
$ r
r r -> r -> r
forall a. Semigroup a => a -> a -> a
<> r
r'

instance (Semigroup l, Semigroup r, Monoid r) => Monoid (Either' l r) where
  mempty :: Either' l r
mempty = r -> Either' l r
forall l r. r -> Either' l r
Right' r
forall a. Monoid a => a
mempty
  mappend :: Either' l r -> Either' l r -> Either' l r
mappend = Either' l r -> Either' l r -> Either' l r
forall a. Semigroup a => a -> a -> a
(<>)

either' :: (l -> a) -> (r -> a) -> Either' l r -> a
either' :: (l -> a) -> (r -> a) -> Either' l r -> a
either' l -> a
lf r -> a
_  (Left' l
l)  = l -> a
lf l
l
either' l -> a
_  r -> a
rf (Right' r
r) = r -> a
rf r
r
-- TODO: Use Validation instead of this home-brew one

-- | Parse a sequence of path operations.
readPathOperations :: Coordinate r => Text -> Either Text [Operation r]
readPathOperations :: Text -> Either Text [Operation r]
readPathOperations = Either' [ParseError] [Operation r] -> Either Text [Operation r]
forall b. Either' [ParseError] b -> Either Text b
unWrap (Either' [ParseError] [Operation r] -> Either Text [Operation r])
-> (Text -> Either' [ParseError] [Operation r])
-> Text
-> Either Text [Operation r]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Either' [ParseError] [Operation r]]
-> Either' [ParseError] [Operation r]
forall a. Monoid a => [a] -> a
mconcat ([Either' [ParseError] [Operation r]]
 -> Either' [ParseError] [Operation r])
-> (Text -> [Either' [ParseError] [Operation r]])
-> Text
-> Either' [ParseError] [Operation r]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text -> Either' [ParseError] [Operation r])
-> [Text] -> [Either' [ParseError] [Operation r]]
forall a b. (a -> b) -> [a] -> [b]
map (Either ParseError (Operation r, Text)
-> Either' [ParseError] [Operation r]
forall a a b. Either a (a, b) -> Either' [a] [a]
wrap (Either ParseError (Operation r, Text)
 -> Either' [ParseError] [Operation r])
-> (Text -> Either ParseError (Operation r, Text))
-> Text
-> Either' [ParseError] [Operation r]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Parser (Operation r)
-> Text -> Either ParseError (Operation r, Text)
forall a. Parser a -> Text -> Either ParseError (a, Text)
runP Parser (Operation r)
forall r. Coordinate r => Parser (Operation r)
pOperation)
                   ([Text] -> [Either' [ParseError] [Operation r]])
-> (Text -> [Text]) -> Text -> [Either' [ParseError] [Operation r]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Text] -> [Text]
clean ([Text] -> [Text]) -> (Text -> [Text]) -> Text -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text -> [Text]
splitKeepDelims String
"mlcqeasuh"
    where
      -- Unwrap the Either'. If it is a Left containing all our errors,
      -- combine them into one error. Otherwise just ReWrap it in an proper Either
      unWrap :: Either' [ParseError] b -> Either Text b
unWrap = ([ParseError] -> Either Text b)
-> (b -> Either Text b) -> Either' [ParseError] b -> Either Text b
forall l a r. (l -> a) -> (r -> a) -> Either' l r -> a
either' (Text -> Either Text b
forall a b. a -> Either a b
Left (Text -> Either Text b)
-> ([ParseError] -> Text) -> [ParseError] -> Either Text b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [ParseError] -> Text
combineErrors) b -> Either Text b
forall a b. b -> Either a b
Right
      -- for the lefts: wrap the error in a list, for the rights: we only care
      -- about the result, so wrap that in a list as well. Collecting the
      -- results is done using the Semigroup instance of Either'
      wrap :: Either a (a, b) -> Either' [a] [a]
wrap   = (a -> Either' [a] [a])
-> ((a, b) -> Either' [a] [a])
-> Either a (a, b)
-> Either' [a] [a]
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either ([a] -> Either' [a] [a]
forall l r. l -> Either' l r
Left' ([a] -> Either' [a] [a]) -> (a -> [a]) -> a -> Either' [a] [a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> [a] -> [a]
forall a. a -> [a] -> [a]
:[])) ([a] -> Either' [a] [a]
forall l r. r -> Either' l r
Right' ([a] -> Either' [a] [a])
-> ((a, b) -> [a]) -> (a, b) -> Either' [a] [a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> [a] -> [a]
forall a. a -> [a] -> [a]
:[]) (a -> [a]) -> ((a, b) -> a) -> (a, b) -> [a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a, b) -> a
forall a b. (a, b) -> a
fst)
      -- Split the input string in pieces, each piece represents one operation
      trim :: Text -> Text
trim   = (Char -> Bool) -> Text -> Text
T.dropWhile Char -> Bool
isSpace
      clean :: [Text] -> [Text]
clean  = (Text -> Bool) -> [Text] -> [Text]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (Text -> Bool) -> Text -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Bool
T.null) ([Text] -> [Text]) -> ([Text] -> [Text]) -> [Text] -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text -> Text) -> [Text] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map Text -> Text
trim
      -- TODO: Do the splitting on the Text rather than unpacking and packing
      -- the thing

errorText :: ParseError -> Text
errorText :: ParseError -> Text
errorText = String -> Text
T.pack (String -> Text) -> (ParseError -> String) -> ParseError -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> String
unlines ([String] -> String)
-> (ParseError -> [String]) -> ParseError -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Message -> String) -> [Message] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Message -> String
messageString ([Message] -> [String])
-> (ParseError -> [Message]) -> ParseError -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ParseError -> [Message]
errorMessages

combineErrors :: [ParseError] -> Text
combineErrors :: [ParseError] -> Text
combineErrors = [Text] -> Text
T.unlines ([Text] -> Text)
-> ([ParseError] -> [Text]) -> [ParseError] -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ParseError -> Text) -> [ParseError] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map ParseError -> Text
errorText


splitKeepDelims          :: [Char] -> Text -> [Text]
splitKeepDelims :: String -> Text -> [Text]
splitKeepDelims String
delims Text
t = [Text] -> ((Char, Text) -> [Text]) -> Maybe (Char, Text) -> [Text]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [Text]
mPref (Char, Text) -> [Text]
continue (Maybe (Char, Text) -> [Text]) -> Maybe (Char, Text) -> [Text]
forall a b. (a -> b) -> a -> b
$ Text -> Maybe (Char, Text)
T.uncons Text
rest
  where
    mPref :: [Text]
mPref           = if Text -> Bool
T.null Text
pref then [] else [Text
pref]
    (Text
pref,Text
rest)     = (Char -> Bool) -> Text -> (Text, Text)
T.break (Char -> String -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` String
delims) Text
t
    continue :: (Char, Text) -> [Text]
continue (Char
c,Text
t') = Text
pref Text -> Char -> Text
`T.snoc` Char
c Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: String -> Text -> [Text]
splitKeepDelims String
delims Text
t'


-- | Try to read/parse a matrix.
readMatrix :: Coordinate r => Text -> Either Text (Matrix 3 3 r)
readMatrix :: Text -> Either Text (Matrix 3 3 r)
readMatrix = Parser (Matrix 3 3 r) -> Text -> Either Text (Matrix 3 3 r)
forall a. Parser a -> Text -> Either Text a
runParser Parser (Matrix 3 3 r)
forall r. Coordinate r => Parser (Matrix 3 3 r)
pMatrix

-- | Try to read/parse a Rectangle
readRectangle :: Coordinate r => Text -> Either Text (Rectangle () r)
readRectangle :: Text -> Either Text (Rectangle () r)
readRectangle = Parser (Rectangle () r) -> Text -> Either Text (Rectangle () r)
forall a. Parser a -> Text -> Either Text a
runParser Parser (Rectangle () r)
forall r. Coordinate r => Parser (Rectangle () r)
pRectangle

-----------------------------------------------------------------------
-- * The parsers themselves

-- |  Parse an operation
pOperation :: forall r. Coordinate r => Parser (Operation r)
pOperation :: Parser (Operation r)
pOperation = [Parser (Operation r)] -> Parser (Operation r)
forall a. [Parser a] -> Parser a
pChoice [ Point 2 r -> Operation r
forall r. Point 2 r -> Operation r
MoveTo       (Point 2 r -> Operation r)
-> ParsecT Text () Identity (Point 2 r) -> Parser (Operation r)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT Text () Identity (Point 2 r)
forall r. Coordinate r => Parser (Point 2 r)
pPoint                         ParsecT Text () Identity (Point 2 r)
-> Char -> ParsecT Text () Identity (Point 2 r)
forall b.
ParsecT Text () Identity b -> Char -> ParsecT Text () Identity b
*>> Char
'm'
                     , Point 2 r -> Operation r
forall r. Point 2 r -> Operation r
LineTo       (Point 2 r -> Operation r)
-> ParsecT Text () Identity (Point 2 r) -> Parser (Operation r)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT Text () Identity (Point 2 r)
forall r. Coordinate r => Parser (Point 2 r)
pPoint                         ParsecT Text () Identity (Point 2 r)
-> Char -> ParsecT Text () Identity (Point 2 r)
forall b.
ParsecT Text () Identity b -> Char -> ParsecT Text () Identity b
*>> Char
'l'
                     , Matrix 3 3 r -> Operation r
forall r. Matrix 3 3 r -> Operation r
Ellipse      (Matrix 3 3 r -> Operation r)
-> ParsecT Text () Identity (Matrix 3 3 r) -> Parser (Operation r)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT Text () Identity (Matrix 3 3 r)
forall r. Coordinate r => Parser (Matrix 3 3 r)
pMatrix                        ParsecT Text () Identity (Matrix 3 3 r)
-> Char -> ParsecT Text () Identity (Matrix 3 3 r)
forall b.
ParsecT Text () Identity b -> Char -> ParsecT Text () Identity b
*>> Char
'e'
                     , Matrix 3 3 r -> Point 2 r -> Operation r
forall r. Matrix 3 3 r -> Point 2 r -> Operation r
ArcTo        (Matrix 3 3 r -> Point 2 r -> Operation r)
-> ParsecT Text () Identity (Matrix 3 3 r)
-> ParsecT Text () Identity (Point 2 r -> Operation r)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT Text () Identity (Matrix 3 3 r)
forall r. Coordinate r => Parser (Matrix 3 3 r)
pMatrix ParsecT Text () Identity (Point 2 r -> Operation r)
-> ParsecT Text () Identity (Point 2 r) -> Parser (Operation r)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ParsecT Text () Identity (Point 2 r)
pPoint'            ParsecT Text () Identity (Point 2 r)
-> Char -> ParsecT Text () Identity (Point 2 r)
forall b.
ParsecT Text () Identity b -> Char -> ParsecT Text () Identity b
*>> Char
'a'
                     , [Point 2 r] -> Operation r
forall r. [Point 2 r] -> Operation r
Spline       ([Point 2 r] -> Operation r)
-> ParsecT Text () Identity [Point 2 r] -> Parser (Operation r)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT Text () Identity (Point 2 r)
forall r. Coordinate r => Parser (Point 2 r)
pPoint ParsecT Text () Identity (Point 2 r)
-> Parser String -> ParsecT Text () Identity [Point 2 r]
forall a b. Parser a -> Parser b -> Parser [a]
`pSepBy` Parser String
pWhiteSpace    ParsecT Text () Identity [Point 2 r]
-> Char -> ParsecT Text () Identity [Point 2 r]
forall b.
ParsecT Text () Identity b -> Char -> ParsecT Text () Identity b
*>> Char
'c'
                     , [Point 2 r] -> Operation r
forall r. [Point 2 r] -> Operation r
ClosedSpline ([Point 2 r] -> Operation r)
-> ParsecT Text () Identity [Point 2 r] -> Parser (Operation r)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT Text () Identity (Point 2 r)
forall r. Coordinate r => Parser (Point 2 r)
pPoint ParsecT Text () Identity (Point 2 r)
-> Parser String -> ParsecT Text () Identity [Point 2 r]
forall a b. Parser a -> Parser b -> Parser [a]
`pSepBy` Parser String
pWhiteSpace    ParsecT Text () Identity [Point 2 r]
-> Char -> ParsecT Text () Identity [Point 2 r]
forall b.
ParsecT Text () Identity b -> Char -> ParsecT Text () Identity b
*>> Char
'u'
                     , Char -> Parser Char
pChar Char
'h'     Parser Char -> Operation r -> Parser (Operation r)
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> Operation r
forall r. Operation r
ClosePath
                     , Point 2 r -> Point 2 r -> Operation r
forall r. Point 2 r -> Point 2 r -> Operation r
QCurveTo     (Point 2 r -> Point 2 r -> Operation r)
-> ParsecT Text () Identity (Point 2 r)
-> ParsecT Text () Identity (Point 2 r -> Operation r)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT Text () Identity (Point 2 r)
forall r. Coordinate r => Parser (Point 2 r)
pPoint ParsecT Text () Identity (Point 2 r -> Operation r)
-> ParsecT Text () Identity (Point 2 r) -> Parser (Operation r)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ParsecT Text () Identity (Point 2 r)
pPoint'             ParsecT Text () Identity (Point 2 r)
-> Char -> ParsecT Text () Identity (Point 2 r)
forall b.
ParsecT Text () Identity b -> Char -> ParsecT Text () Identity b
*>> Char
'q'
                     , Point 2 r -> Point 2 r -> Point 2 r -> Operation r
forall r. Point 2 r -> Point 2 r -> Point 2 r -> Operation r
CurveTo      (Point 2 r -> Point 2 r -> Point 2 r -> Operation r)
-> ParsecT Text () Identity (Point 2 r)
-> ParsecT Text () Identity (Point 2 r -> Point 2 r -> Operation r)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT Text () Identity (Point 2 r)
forall r. Coordinate r => Parser (Point 2 r)
pPoint ParsecT Text () Identity (Point 2 r -> Point 2 r -> Operation r)
-> ParsecT Text () Identity (Point 2 r)
-> ParsecT Text () Identity (Point 2 r -> Operation r)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ParsecT Text () Identity (Point 2 r)
pPoint' ParsecT Text () Identity (Point 2 r -> Operation r)
-> ParsecT Text () Identity (Point 2 r) -> Parser (Operation r)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ParsecT Text () Identity (Point 2 r)
pPoint' ParsecT Text () Identity (Point 2 r)
-> Char -> ParsecT Text () Identity (Point 2 r)
forall b.
ParsecT Text () Identity b -> Char -> ParsecT Text () Identity b
*>> Char
'c'
                     , [Point 2 r] -> Operation r
forall r. [Point 2 r] -> Operation r
Spline       ([Point 2 r] -> Operation r)
-> ParsecT Text () Identity [Point 2 r] -> Parser (Operation r)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT Text () Identity (Point 2 r)
forall r. Coordinate r => Parser (Point 2 r)
pPoint ParsecT Text () Identity (Point 2 r)
-> Parser String -> ParsecT Text () Identity [Point 2 r]
forall a b. Parser a -> Parser b -> Parser [a]
`pSepBy` Parser String
pWhiteSpace    ParsecT Text () Identity [Point 2 r]
-> Char -> ParsecT Text () Identity [Point 2 r]
forall b.
ParsecT Text () Identity b -> Char -> ParsecT Text () Identity b
*>> Char
's'
                     ]
             where
               pPoint' :: ParsecT Text () Identity (Point 2 r)
pPoint' = Parser String
pWhiteSpace Parser String
-> ParsecT Text () Identity (Point 2 r)
-> ParsecT Text () Identity (Point 2 r)
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ParsecT Text () Identity (Point 2 r)
forall r. Coordinate r => Parser (Point 2 r)
pPoint
               ParsecT Text () Identity b
p *>> :: ParsecT Text () Identity b -> Char -> ParsecT Text () Identity b
*>> Char
c = ParsecT Text () Identity b
p ParsecT Text () Identity b
-> Parser Char -> ParsecT Text () Identity b
forall s (m :: * -> *) t u b a.
(Stream s m t, Reversable s) =>
ParsecT s u m b -> ParsecT s u m a -> ParsecT s u m b
<*>< Parser String
pWhiteSpace Parser String -> Parser Char -> Parser Char
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
***> Char -> Parser Char
pChar Char
c

-- * Parse a Point
pPoint :: Coordinate r => Parser (Point 2 r)
pPoint :: Parser (Point 2 r)
pPoint = r -> r -> Point 2 r
forall r. r -> r -> Point 2 r
Point2 (r -> r -> Point 2 r)
-> ParsecT Text () Identity r
-> ParsecT Text () Identity (r -> Point 2 r)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT Text () Identity r
forall r. Coordinate r => Parser r
pCoordinate ParsecT Text () Identity (r -> Point 2 r)
-> Parser String -> ParsecT Text () Identity (r -> Point 2 r)
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser String
pWhiteSpace ParsecT Text () Identity (r -> Point 2 r)
-> ParsecT Text () Identity r -> Parser (Point 2 r)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ParsecT Text () Identity r
forall r. Coordinate r => Parser r
pCoordinate

-- * Parse a single coordinate.
pCoordinate :: Coordinate r => Parser r
pCoordinate :: Parser r
pCoordinate = Integer -> Maybe (Int, Integer) -> r
forall r. Coordinate r => Integer -> Maybe (Int, Integer) -> r
fromSeq (Integer -> Maybe (Int, Integer) -> r)
-> ParsecT Text () Identity Integer
-> ParsecT Text () Identity (Maybe (Int, Integer) -> r)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT Text () Identity Integer
pInteger ParsecT Text () Identity (Maybe (Int, Integer) -> r)
-> ParsecT Text () Identity (Maybe (Int, Integer)) -> Parser r
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ParsecT Text () Identity (Maybe (Int, Integer))
pDecimal
              where
                pDecimal :: ParsecT Text () Identity (Maybe (Int, Integer))
pDecimal  = Parser (Int, Integer)
-> ParsecT Text () Identity (Maybe (Int, Integer))
forall a. Parser a -> Parser (Maybe a)
pMaybe (Char -> Parser Char
pChar Char
'.' Parser Char -> Parser (Int, Integer) -> Parser (Int, Integer)
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser (Int, Integer)
pPaddedNatural)


-- | Parser for a rectangle
pRectangle :: Coordinate r => Parser (Rectangle () r)
pRectangle :: Parser (Rectangle () r)
pRectangle = (\Point 2 r
p Point 2 r
q -> (Point 2 r :+ ()) -> (Point 2 r :+ ()) -> Rectangle () r
forall (d :: Nat) r p.
(Point d r :+ p) -> (Point d r :+ p) -> Box d p r
box (Point 2 r -> Point 2 r :+ ()
forall a. a -> a :+ ()
ext Point 2 r
p) (Point 2 r -> Point 2 r :+ ()
forall a. a -> a :+ ()
ext Point 2 r
q)) (Point 2 r -> Point 2 r -> Rectangle () r)
-> ParsecT Text () Identity (Point 2 r)
-> ParsecT Text () Identity (Point 2 r -> Rectangle () r)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT Text () Identity (Point 2 r)
forall r. Coordinate r => Parser (Point 2 r)
pPoint
                                           ParsecT Text () Identity (Point 2 r -> Rectangle () r)
-> Parser String
-> ParsecT Text () Identity (Point 2 r -> Rectangle () r)
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<*  Parser String
pWhiteSpace
                                           ParsecT Text () Identity (Point 2 r -> Rectangle () r)
-> ParsecT Text () Identity (Point 2 r) -> Parser (Rectangle () r)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ParsecT Text () Identity (Point 2 r)
forall r. Coordinate r => Parser (Point 2 r)
pPoint

-- | Parser for a matrix.
pMatrix :: Coordinate r => Parser (Matrix 3 3 r)
pMatrix :: Parser (Matrix 3 3 r)
pMatrix = (\r
a [r]
b -> [r] -> Matrix 3 3 r
forall r. Coordinate r => [r] -> Matrix 3 3 r
mkMatrix (r
ar -> [r] -> [r]
forall a. a -> [a] -> [a]
:[r]
b)) (r -> [r] -> Matrix 3 3 r)
-> ParsecT Text () Identity r
-> ParsecT Text () Identity ([r] -> Matrix 3 3 r)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT Text () Identity r
forall r. Coordinate r => Parser r
pCoordinate
                                   ParsecT Text () Identity ([r] -> Matrix 3 3 r)
-> ParsecT Text () Identity [r] -> Parser (Matrix 3 3 r)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Int -> ParsecT Text () Identity r -> ParsecT Text () Identity [r]
forall a. Int -> Parser a -> Parser [a]
pCount Int
5 (Parser String
pWhiteSpace Parser String
-> ParsecT Text () Identity r -> ParsecT Text () Identity r
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ParsecT Text () Identity r
forall r. Coordinate r => Parser r
pCoordinate)


-- | Generate a matrix from a list of 6 coordinates.
mkMatrix               :: Coordinate r => [r] -> Matrix 3 3 r
mkMatrix :: [r] -> Matrix 3 3 r
mkMatrix [r
a,r
b,r
c,r
d,r
e,r
f] = Vector 3 (Vector 3 r) -> Matrix 3 3 r
forall (n :: Nat) (m :: Nat) r.
Vector n (Vector m r) -> Matrix n m r
Matrix (Vector 3 (Vector 3 r) -> Matrix 3 3 r)
-> Vector 3 (Vector 3 r) -> Matrix 3 3 r
forall a b. (a -> b) -> a -> b
$ Vector 3 r -> Vector 3 r -> Vector 3 r -> Vector 3 (Vector 3 r)
forall r. r -> r -> r -> Vector 3 r
Vector3 (r -> r -> r -> Vector 3 r
forall r. r -> r -> r -> Vector 3 r
Vector3 r
a r
c r
e)
                                          (r -> r -> r -> Vector 3 r
forall r. r -> r -> r -> Vector 3 r
Vector3 r
b r
d r
f)
                                          (r -> r -> r -> Vector 3 r
forall r. r -> r -> r -> Vector 3 r
Vector3 r
0 r
0 r
1)
                           -- We need the matrix in the following order:
                         -- 012
                         -- 345
                         --
                         -- But ipe uses the following order:
                         -- 024
                         -- 135
mkMatrix [r]
_             = String -> Matrix 3 3 r
forall a. HasCallStack => String -> a
error String
"mkMatrix: need exactly 6 arguments"