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