{-# LANGUAGE CPP #-}
module Data.GraphViz.PreProcessing(preProcess) where
import Data.GraphViz.Exception (GraphvizException (NotDotCode), throw)
import Data.GraphViz.Parsing
import Data.Text.Lazy (Text)
import qualified Data.Text.Lazy as T
import Data.Text.Lazy.Builder (Builder)
import qualified Data.Text.Lazy.Builder as B
#if !(MIN_VERSION_base(4,8,0))
import Data.Monoid (Monoid (..), mconcat)
#endif
preProcess :: Text -> Text
preProcess :: Text -> Text
preProcess t :: Text
t = case (Either String Builder, Text) -> Either String Builder
forall a b. (a, b) -> a
fst ((Either String Builder, Text) -> Either String Builder)
-> (Either String Builder, Text) -> Either String Builder
forall a b. (a -> b) -> a -> b
$ Parse Builder -> Text -> (Either String Builder, Text)
forall a. Parse a -> Text -> (Either String a, Text)
runParser Parse Builder
parseOutUnwanted Text
t of
(Right r :: Builder
r) -> Builder -> Text
B.toLazyText Builder
r
(Left l :: String
l) -> GraphvizException -> Text
forall a e. Exception e => e -> a
throw (String -> GraphvizException
NotDotCode String
l)
parseOutUnwanted :: Parse Builder
parseOutUnwanted :: Parse Builder
parseOutUnwanted = [Builder] -> Builder
forall a. Monoid a => [a] -> a
mconcat ([Builder] -> Builder)
-> Parser GraphvizState [Builder] -> Parse Builder
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parse Builder -> Parser GraphvizState [Builder]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
many Parse Builder
getNext
where
getNext :: Parse Builder
getNext = Parse Builder
forall s. Parser s Builder
parseOK
Parse Builder -> Parse Builder -> Parse Builder
forall s a. Parser s a -> Parser s a -> Parser s a
`onFail`
Parse Builder
parseConcatStrings
Parse Builder -> Parse Builder -> Parse Builder
forall s a. Parser s a -> Parser s a -> Parser s a
`onFail`
Parse Builder
parseHTML
Parse Builder -> Parse Builder -> Parse Builder
forall s a. Parser s a -> Parser s a -> Parser s a
`onFail`
Parse Builder
forall m. Monoid m => Parse m
parseUnwanted
Parse Builder -> Parse Builder -> Parse Builder
forall s a. Parser s a -> Parser s a -> Parser s a
`onFail`
(Char -> Builder) -> Parser GraphvizState Char -> Parse Builder
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Char -> Builder
B.singleton Parser GraphvizState Char
forall s. Parser s Char
next
parseOK :: Parser s Builder
parseOK = Text -> Builder
B.fromLazyText
(Text -> Builder) -> Parser s Text -> Parser s Builder
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Char -> Bool) -> Parser s Text
forall s. (Char -> Bool) -> Parser s Text
many1Satisfy (Char -> String -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` ['\n', '\r', '\\', '/', '"', '<'])
parseUnwanted :: (Monoid m) => Parse m
parseUnwanted :: Parse m
parseUnwanted = [Parse m] -> Parse m
forall (p :: * -> *) a. PolyParse p => [p a] -> p a
oneOf [ Parse m
forall m. Monoid m => Parse m
parseLineComment
, Parse m
forall m. Monoid m => Parse m
parseMultiLineComment
, Parse m
forall m. Monoid m => Parse m
parsePreProcessor
, Parse m
forall m. Monoid m => Parse m
parseSplitLine
]
parsePreProcessor :: (Monoid m) => Parse m
parsePreProcessor :: Parse m
parsePreProcessor = Parse ()
newline Parse () -> Parser GraphvizState Char -> Parser GraphvizState Char
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Char -> Parser GraphvizState Char
character '#' Parser GraphvizState Char
-> Parser GraphvizState Text -> Parser GraphvizState Text
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser GraphvizState Text
consumeLine Parser GraphvizState Text -> Parse m -> Parse m
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> m -> Parse m
forall (f :: * -> *) a. Applicative f => a -> f a
pure m
forall a. Monoid a => a
mempty
parseLineComment :: (Monoid m) => Parse m
= String -> Parse ()
string "//"
Parse () -> Parser GraphvizState Text -> Parser GraphvizState Text
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser GraphvizState Text
consumeLine
Parser GraphvizState Text -> Parse m -> Parse m
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> m -> Parse m
forall (f :: * -> *) a. Applicative f => a -> f a
pure m
forall a. Monoid a => a
mempty
parseMultiLineComment :: (Monoid m) => Parse m
= Parse ()
-> Parse ()
-> Parser GraphvizState [()]
-> Parser GraphvizState [()]
forall (p :: * -> *) bra ket a.
PolyParse p =>
p bra -> p ket -> p a -> p a
bracket Parse ()
start Parse ()
end (Parse () -> Parser GraphvizState [()]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
many Parse ()
inner) Parser GraphvizState [()] -> Parse m -> Parse m
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> m -> Parse m
forall (f :: * -> *) a. Applicative f => a -> f a
pure m
forall a. Monoid a => a
mempty
where
start :: Parse ()
start = String -> Parse ()
string "/*"
end :: Parse ()
end = String -> Parse ()
string "*/"
inner :: Parse ()
inner = ((Char -> Bool) -> Parser GraphvizState Text
forall s. (Char -> Bool) -> Parser s Text
many1Satisfy ('*' Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/=) Parser GraphvizState Text -> Parse () -> Parse ()
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> () -> Parse ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ())
Parse () -> Parse () -> Parse ()
forall s a. Parser s a -> Parser s a -> Parser s a
`onFail`
(Char -> Parser GraphvizState Char
character '*' Parser GraphvizState Char
-> Parser GraphvizState Char -> Parser GraphvizState Char
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> (Char -> Bool) -> Parser GraphvizState Char
forall s. (Char -> Bool) -> Parser s Char
satisfy ('/' Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/=) Parser GraphvizState Char -> Parse () -> Parse ()
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parse ()
inner)
parseConcatStrings :: Parse Builder
parseConcatStrings :: Parse Builder
parseConcatStrings = Builder -> Builder
wrapQuotes (Builder -> Builder)
-> ([Builder] -> Builder) -> [Builder] -> Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Builder] -> Builder
forall a. Monoid a => [a] -> a
mconcat ([Builder] -> Builder)
-> Parser GraphvizState [Builder] -> Parse Builder
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parse Builder
-> Parser GraphvizState [()] -> Parser GraphvizState [Builder]
forall (p :: * -> *) a sep. PolyParse p => p a -> p sep -> p [a]
sepBy1 Parse Builder
parseString Parser GraphvizState [()]
parseConcat
where
qParse :: Parser GraphvizState a -> Parser GraphvizState a
qParse = Parser GraphvizState Char
-> Parser GraphvizState Char
-> Parser GraphvizState a
-> Parser GraphvizState a
forall (p :: * -> *) bra ket a.
PolyParse p =>
p bra -> p ket -> p a -> p a
bracket (Char -> Parser GraphvizState Char
character '"') (Parser GraphvizState Char -> Parser GraphvizState Char
forall (p :: * -> *) a. Commitment p => p a -> p a
commit (Parser GraphvizState Char -> Parser GraphvizState Char)
-> Parser GraphvizState Char -> Parser GraphvizState Char
forall a b. (a -> b) -> a -> b
$ Char -> Parser GraphvizState Char
character '"')
parseString :: Parse Builder
parseString = Parse Builder -> Parse Builder
forall a. Parser GraphvizState a -> Parser GraphvizState a
qParse ([Builder] -> Builder
forall a. Monoid a => [a] -> a
mconcat ([Builder] -> Builder)
-> Parser GraphvizState [Builder] -> Parse Builder
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parse Builder -> Parser GraphvizState [Builder]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
many Parse Builder
parseInner)
parseInner :: Parse Builder
parseInner = (String -> Parse ()
string "\\\"" Parse () -> Parse Builder -> Parse Builder
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Builder -> Parse Builder
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text -> Builder
B.fromLazyText (Text -> Builder) -> Text -> Builder
forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack "\\\""))
Parse Builder -> Parse Builder -> Parse Builder
forall s a. Parser s a -> Parser s a -> Parser s a
`onFail`
(String -> Parse ()
string "\\\\" Parse () -> Parse Builder -> Parse Builder
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Builder -> Parse Builder
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text -> Builder
B.fromLazyText (Text -> Builder) -> Text -> Builder
forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack "\\\\"))
Parse Builder -> Parse Builder -> Parse Builder
forall s a. Parser s a -> Parser s a -> Parser s a
`onFail`
Parse Builder
forall m. Monoid m => Parse m
parseSplitLine
Parse Builder -> Parse Builder -> Parse Builder
forall s a. Parser s a -> Parser s a -> Parser s a
`onFail`
(Char -> Builder) -> Parser GraphvizState Char -> Parse Builder
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Char -> Builder
B.singleton ((Char -> Bool) -> Parser GraphvizState Char
forall s. (Char -> Bool) -> Parser s Char
satisfy (Char
quoteChar Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/=))
parseConcat :: Parser GraphvizState [()]
parseConcat = Parser GraphvizState [()]
parseSep Parser GraphvizState [()]
-> Parser GraphvizState Char -> Parser GraphvizState Char
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Char -> Parser GraphvizState Char
character '+' Parser GraphvizState Char
-> Parser GraphvizState [()] -> Parser GraphvizState [()]
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser GraphvizState [()]
parseSep
parseSep :: Parser GraphvizState [()]
parseSep = Parse () -> Parser GraphvizState [()]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
many (Parse () -> Parser GraphvizState [()])
-> Parse () -> Parser GraphvizState [()]
forall a b. (a -> b) -> a -> b
$ Parse ()
whitespace1 Parse () -> Parse () -> Parse ()
forall s a. Parser s a -> Parser s a -> Parser s a
`onFail` Parse ()
forall m. Monoid m => Parse m
parseUnwanted
wrapQuotes :: Builder -> Builder
wrapQuotes str :: Builder
str = Builder
qc Builder -> Builder -> Builder
forall a. Monoid a => a -> a -> a
`mappend` Builder
str Builder -> Builder -> Builder
forall a. Monoid a => a -> a -> a
`mappend` Builder
qc
qc :: Builder
qc = Char -> Builder
B.singleton '"'
parseSplitLine :: (Monoid m) => Parse m
parseSplitLine :: Parse m
parseSplitLine = Char -> Parser GraphvizState Char
character '\\' Parser GraphvizState Char -> Parse () -> Parse ()
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parse ()
newline Parse () -> Parse m -> Parse m
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> m -> Parse m
forall (f :: * -> *) a. Applicative f => a -> f a
pure m
forall a. Monoid a => a
mempty
parseHTML :: Parse Builder
parseHTML :: Parse Builder
parseHTML = ([Builder] -> Builder)
-> Parser GraphvizState [Builder] -> Parse Builder
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Builder -> Builder
addAngled (Builder -> Builder)
-> ([Builder] -> Builder) -> [Builder] -> Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Builder] -> Builder
forall a. Monoid a => [a] -> a
mconcat)
(Parser GraphvizState [Builder] -> Parse Builder)
-> (Parser GraphvizState [Builder]
-> Parser GraphvizState [Builder])
-> Parser GraphvizState [Builder]
-> Parse Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Parser GraphvizState [Builder] -> Parser GraphvizState [Builder]
forall a. Parser GraphvizState a -> Parser GraphvizState a
parseAngled (Parser GraphvizState [Builder] -> Parse Builder)
-> Parser GraphvizState [Builder] -> Parse Builder
forall a b. (a -> b) -> a -> b
$ Parse Builder -> Parser GraphvizState [Builder]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
many Parse Builder
inner
where
inner :: Parse Builder
inner = Parse Builder
parseHTML
Parse Builder -> Parse Builder -> Parse Builder
forall s a. Parser s a -> Parser s a -> Parser s a
`onFail`
(Text -> Builder
B.fromLazyText (Text -> Builder) -> Parser GraphvizState Text -> Parse Builder
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Char -> Bool) -> Parser GraphvizState Text
forall s. (Char -> Bool) -> Parser s Text
many1Satisfy (\c :: Char
c -> Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
open Bool -> Bool -> Bool
&& Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
close))
addAngled :: Builder -> Builder
addAngled str :: Builder
str = Char -> Builder
B.singleton Char
open Builder -> Builder -> Builder
forall a. Monoid a => a -> a -> a
`mappend` Builder
str Builder -> Builder -> Builder
forall a. Monoid a => a -> a -> a
`mappend` Char -> Builder
B.singleton Char
close
open :: Char
open = '<'
close :: Char
close = '>'