module Data.GraphViz.PreProcessing(preProcess) where
import Data.GraphViz.Parsing
import Data.GraphViz.Exception(GraphvizException(NotDotCode), throw)
import qualified Data.Text.Lazy as T
import Data.Text.Lazy(Text)
import qualified Data.Text.Lazy.Builder as B
import Data.Text.Lazy.Builder(Builder)
import Data.Monoid(Monoid(..), mconcat)
import Control.Monad(liftM)
preProcess :: Text -> Text
preProcess t = case fst $ runParser parseOutUnwanted t of
(Right r) -> B.toLazyText r
(Left l) -> throw (NotDotCode l)
parseOutUnwanted :: Parse Builder
parseOutUnwanted = liftM mconcat (many getNext)
where
getNext = parseOK
`onFail`
parseConcatStrings
`onFail`
parseHTML
`onFail`
parseUnwanted
`onFail`
liftM B.singleton next
parseOK = liftM B.fromLazyText
$ many1Satisfy (`notElem` ['\n', '\r', '\\', '/', '"', '<'])
parseUnwanted :: (Monoid m) => Parse m
parseUnwanted = oneOf [ parseLineComment
, parseMultiLineComment
, parsePreProcessor
, parseSplitLine
]
parsePreProcessor :: (Monoid m) => Parse m
parsePreProcessor = do newline
character '#'
consumeLine
return mempty
parseLineComment :: (Monoid m) => Parse m
parseLineComment = do string "//"
consumeLine
return mempty
parseMultiLineComment :: (Monoid m) => Parse m
parseMultiLineComment = bracket start end (many inner)
>> return mempty
where
start = string "/*"
end = string "*/"
inner = (many1Satisfy ('*' /=) >> return ())
`onFail`
do character '*'
satisfy ('/' /=)
inner
parseConcatStrings :: Parse Builder
parseConcatStrings = liftM (wrapQuotes . mconcat)
$ sepBy1 parseString parseConcat
where
qParse = bracket (character '"') (commit $ character '"')
parseString = qParse (liftM mconcat $ many parseInner)
parseInner = (string "\\\"" >> return (B.fromLazyText $ T.pack "\\\""))
`onFail`
(string "\\\\" >> return (B.fromLazyText $ T.pack "\\\\"))
`onFail`
parseSplitLine
`onFail`
liftM B.singleton (satisfy (quoteChar /=))
parseConcat = parseSep >> character '+' >> parseSep
parseSep = many $ allWhitespace `onFail` parseUnwanted
wrapQuotes str = qc `mappend` str `mappend` qc
qc = B.singleton '"'
parseSplitLine :: (Monoid m) => Parse m
parseSplitLine = character '\\' >> newline >> return mempty
parseHTML :: Parse Builder
parseHTML = liftM (addAngled . mconcat)
. parseAngled $ many inner
where
inner = parseHTML
`onFail`
(liftM B.fromLazyText $ many1Satisfy (\c -> c /= open && c /= close))
addAngled str = B.singleton open `mappend` str `mappend` B.singleton close
open = '<'
close = '>'