{-# OPTIONS_GHC -fno-warn-unused-do-bind #-}

{-# LANGUAGE MultiParamTypeClasses #-}

module Diagrams.TwoD.Path.Metafont.Parser
       (metafontParser) where

import           Text.Parsec
import           Text.Parsec.Text

import           Diagrams.Prelude                  hiding (option)
import           Diagrams.TwoD.Path.Metafont.Types

num :: Read n => Parser n
num :: forall n. Read n => Parser n
num = forall a. Read a => String -> a
read forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall {u}. ParsecT Text u Identity String
float where
  sign :: ParsecT Text u Identity String
sign = forall {u}. ParsecT Text u Identity String
plus forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> forall {u}. ParsecT Text u Identity String
minus forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> forall {u}. ParsecT Text u Identity String
unsigned
  plus :: ParsecT Text u Identity String
plus = forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
'+' forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall {u}. ParsecT Text u Identity String
unsigned
  minus :: ParsecT Text u Identity String
minus = (:) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
'-' forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall {u}. ParsecT Text u Identity String
unsigned
  unsigned :: ParsecT Text u Identity String
unsigned = forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m [a]
many1 forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
digit
  decimal :: ParsecT Text u Identity String
decimal = forall s (m :: * -> *) t a u.
Stream s m t =>
a -> ParsecT s u m a -> ParsecT s u m a
option String
"" (forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m a
try forall a b. (a -> b) -> a -> b
$ (:) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
'.' forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall {u}. ParsecT Text u Identity String
unsigned)
  float :: ParsecT Text u Identity String
float = forall a. [a] -> [a] -> [a]
(++) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall {u}. ParsecT Text u Identity String
sign forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall {u}. ParsecT Text u Identity String
decimal

-- points

xy :: Read n => Parser (n, n)
xy :: forall n. Read n => Parser (n, n)
xy = do
  forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m ()
spaces
  n
x <- forall n. Read n => Parser n
num
  forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m ()
spaces forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
',' forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m ()
spaces
  n
y <- forall n. Read n => Parser n
num
  forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m ()
spaces
  forall (m :: * -> *) a. Monad m => a -> m a
return (n
x,n
y)

pt :: Read n => Parser (P2 n)
pt :: forall n. Read n => Parser (P2 n)
pt = forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
'(' forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> (forall n. (n, n) -> P2 n
p2 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall n. Read n => Parser (n, n)
xy) forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
')'

-- Joins

anyJoin :: (Num n, Read n) => Parser (PathJoin (Maybe (PathDir n)) (BasicJoin n))
anyJoin :: forall n.
(Num n, Read n) =>
Parser (PathJoin (Maybe (PathDir n)) (BasicJoin n))
anyJoin = forall n.
Num n =>
Parser (PathJoin (Maybe (PathDir n)) (BasicJoin n))
straightJoin forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> do
  Maybe (PathDir n)
d1' <- forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m (Maybe a)
optionMaybe forall n. Read n => Parser (PathDir n)
pathDir
  BasicJoin n
j' <- forall n. Num n => Parser (BasicJoin n)
tenseLine forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> forall n. (Num n, Read n) => Parser (BasicJoin n)
dotsJoin
  Maybe (PathDir n)
d2' <- forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m (Maybe a)
optionMaybe forall n. Read n => Parser (PathDir n)
pathDir
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall d j. d -> j -> d -> PathJoin d j
PJ Maybe (PathDir n)
d1' BasicJoin n
j' Maybe (PathDir n)
d2'

dotsJoin :: (Num n, Read n) => Parser (BasicJoin n)
dotsJoin :: forall n. (Num n, Read n) => Parser (BasicJoin n)
dotsJoin = forall s (m :: * -> *) u.
Stream s m Char =>
String -> ParsecT s u m String
string String
".." forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m ()
spaces forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*>
           (forall n. Num n => Parser (BasicJoin n)
boundedJoin forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|>forall n. Read n => Parser (BasicJoin n)
tensionJoin forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> forall n. Read n => Parser (BasicJoin n)
controlJoin forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> forall n. Num n => Parser (BasicJoin n)
plainJoin)

plainJoin :: Num n => Parser (BasicJoin n)
plainJoin :: forall n. Num n => Parser (BasicJoin n)
plainJoin = forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ forall n. Tension n -> Tension n -> TensionJoin n
TJ Tension n
t1' Tension n
t1') where
  t1' :: Tension n
t1' = forall n. n -> Tension n
TensionAmt n
1

tensionJoin :: Read n => Parser (BasicJoin n)
tensionJoin :: forall n. Read n => Parser (BasicJoin n)
tensionJoin = do
  forall s (m :: * -> *) u.
Stream s m Char =>
String -> ParsecT s u m String
string String
"tension"
  forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m ()
spaces
  n
t1' <- forall n. Read n => Parser n
num
  n
t2' <- forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m a
try (forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m ()
spaces forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall s (m :: * -> *) u.
Stream s m Char =>
String -> ParsecT s u m String
string String
"and" forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m ()
spaces forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall n. Read n => Parser n
num forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m ()
spaces) forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> forall (f :: * -> *) a. Applicative f => a -> f a
pure n
t1'
  forall s (m :: * -> *) u.
Stream s m Char =>
String -> ParsecT s u m String
string String
".."
  forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ forall n. Tension n -> Tension n -> TensionJoin n
TJ (forall n. n -> Tension n
TensionAmt n
t1') (forall n. n -> Tension n
TensionAmt n
t2')

controlJoin :: Read n => Parser (BasicJoin n)
controlJoin :: forall n. Read n => Parser (BasicJoin n)
controlJoin = do
  forall s (m :: * -> *) u.
Stream s m Char =>
String -> ParsecT s u m String
string String
"controls" forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m ()
spaces
  P2 n
z1 <- forall n. Read n => Parser (P2 n)
pt
  forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m ()
spaces forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall s (m :: * -> *) u.
Stream s m Char =>
String -> ParsecT s u m String
string String
"and" forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m ()
spaces
  P2 n
z2 <- forall n. Read n => Parser (P2 n)
pt
  forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m ()
spaces forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall s (m :: * -> *) u.
Stream s m Char =>
String -> ParsecT s u m String
string String
".."
  forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ forall n. P2 n -> P2 n -> ControlJoin n
CJ P2 n
z1 P2 n
z2

boundedJoin :: Num n => Parser (BasicJoin n)
boundedJoin :: forall n. Num n => Parser (BasicJoin n)
boundedJoin = forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
'.' forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ forall n. Tension n -> Tension n -> TensionJoin n
TJ Tension n
t Tension n
t) where t :: Tension n
t = forall n. n -> Tension n
TensionAtLeast n
1

straightJoin :: Num n => Parser (PathJoin (Maybe (PathDir n)) (BasicJoin n))
straightJoin :: forall n.
Num n =>
Parser (PathJoin (Maybe (PathDir n)) (BasicJoin n))
straightJoin = forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m a
try (forall s (m :: * -> *) u.
Stream s m Char =>
String -> ParsecT s u m String
string String
"--" forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall s (m :: * -> *) t a u.
(Stream s m t, Show a) =>
ParsecT s u m a -> ParsecT s u m ()
notFollowedBy (forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
'-')) forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall d j. d -> j -> d -> PathJoin d j
PJ Maybe (PathDir n)
c forall {b}. Either (TensionJoin n) b
jj Maybe (PathDir n)
c)
  where
    c :: Maybe (PathDir n)
c = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall n. n -> PathDir n
PathDirCurl n
1
    jj :: Either (TensionJoin n) b
jj = forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ forall n. Tension n -> Tension n -> TensionJoin n
TJ (forall n. n -> Tension n
TensionAmt n
1) (forall n. n -> Tension n
TensionAmt n
1)

tenseLine :: Num n => Parser (BasicJoin n)
-- 4096 is the constant 'infinity' in Plain MetaFont
tenseLine :: forall n. Num n => Parser (BasicJoin n)
tenseLine = forall s (m :: * -> *) u.
Stream s m Char =>
String -> ParsecT s u m String
string String
"---" forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ forall n. Tension n -> Tension n -> TensionJoin n
TJ Tension n
t Tension n
t) where t :: Tension n
t = forall n. n -> Tension n
TensionAmt n
4096

-- Directions

dir :: Read n => Parser (PathDir n)
dir :: forall n. Read n => Parser (PathDir n)
dir = forall n. Dir n -> PathDir n
PathDirDir forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (v :: * -> *) n. v n -> Direction v n
direction forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall n. (n, n) -> V2 n
r2 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall n. Read n => Parser (n, n)
xy

curl :: Read n => Parser (PathDir n)
curl :: forall n. Read n => Parser (PathDir n)
curl = forall n. n -> PathDir n
PathDirCurl forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall s (m :: * -> *) u.
Stream s m Char =>
String -> ParsecT s u m String
string String
"curl" forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m ()
spaces forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall n. Read n => Parser n
num)

pathDir :: Read n => Parser (PathDir n)
pathDir :: forall n. Read n => Parser (PathDir n)
pathDir = do
  forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
'{' forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m ()
spaces
  PathDir n
d <- forall n. Read n => Parser (PathDir n)
curl forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> forall n. Read n => Parser (PathDir n)
dir
  forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m ()
spaces forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
'}'
  forall (m :: * -> *) a. Monad m => a -> m a
return PathDir n
d

-- Segments & Paths

mfs :: (Num n, Read n) => Parser (MetafontSegment (Maybe (PathDir n)) (BasicJoin n) n)
mfs :: forall n.
(Num n, Read n) =>
Parser (MetafontSegment (Maybe (PathDir n)) (BasicJoin n) n)
mfs = forall d j n. P2 n -> PathJoin d j -> P2 n -> MetafontSegment d j n
MFS forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall n. Read n => Parser (P2 n)
pt forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall n.
(Num n, Read n) =>
Parser (PathJoin (Maybe (PathDir n)) (BasicJoin n))
anyJoin forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m a
lookAhead forall n. Read n => Parser (P2 n)
pt

matches :: Stream s m t => ParsecT s u m a -> ParsecT s u m Bool
matches :: forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m Bool
matches ParsecT s u m a
p = forall s (m :: * -> *) t a u.
Stream s m t =>
a -> ParsecT s u m a -> ParsecT s u m a
option Bool
False (ParsecT s u m a
p forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True)

-- | Parse a 'Text' value in Metafont syntax, as destribed in /The
-- METAFONTbook/.
metafontParser :: (Num n, Read n) => Parser (MFPath (Maybe (PathDir n)) (BasicJoin n) n)
metafontParser :: forall n.
(Num n, Read n) =>
Parser (MFPath (Maybe (PathDir n)) (BasicJoin n) n)
metafontParser = do
  [MetafontSegment (Maybe (PathDir n)) (BasicJoin n) n]
ss <- forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m [a]
many1 (forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m a
try forall n.
(Num n, Read n) =>
Parser (MetafontSegment (Maybe (PathDir n)) (BasicJoin n) n)
mfs)
  P2 n
lastP <- forall n. Read n => Parser (P2 n)
pt
  Maybe (PathDir n)
lastD <- forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m (Maybe a)
optionMaybe forall n. Read n => Parser (PathDir n)
pathDir
  Bool
c  <- forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m Bool
matches forall a b. (a -> b) -> a -> b
$ forall s (m :: * -> *) u.
Stream s m Char =>
String -> ParsecT s u m String
string String
"..cycle"
  if Bool
c
     then forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall d j n. Bool -> [MetafontSegment d j n] -> MFPath d j n
MFP Bool
c forall a b. (a -> b) -> a -> b
$ [MetafontSegment (Maybe (PathDir n)) (BasicJoin n) n]
ss forall a. [a] -> [a] -> [a]
++ [forall d j n. P2 n -> PathJoin d j -> P2 n -> MetafontSegment d j n
MFS P2 n
lastP (forall d j. d -> j -> d -> PathJoin d j
PJ Maybe (PathDir n)
lastD (forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ forall n. Tension n -> Tension n -> TensionJoin n
TJ (forall n. n -> Tension n
TensionAmt n
1) (forall n. n -> Tension n
TensionAmt n
1)) forall a. Maybe a
Nothing) (forall a. [a] -> a
head [MetafontSegment (Maybe (PathDir n)) (BasicJoin n) n]
ssforall s a. s -> Getting a s a -> a
^.forall d j n. Lens' (MetafontSegment d j n) (P2 n)
x1)]
    else forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall d j n. Bool -> [MetafontSegment d j n] -> MFPath d j n
MFP Bool
c [MetafontSegment (Maybe (PathDir n)) (BasicJoin n) n]
ss