{-# LANGUAGE CPP #-}

{- |
   Module      : Data.GraphViz.PreProcessing
   Description : Pre-process imported Dot code.
   Copyright   : (c) Ivan Lazar Miljenovic
   License     : 3-Clause BSD-style
   Maintainer  : Ivan.Miljenovic@gmail.com

   \"Real life\" Dot code contains various items that are not directly
   parseable by this library.  This module defines the 'preProcess'
   function to remove these components, which include:

     * Comments (both @\/\* ... *\/@ style and @\/\/ ... @ style);

     * Pre-processor lines (lines starting with a @#@);

     * Split lines (by inserting a @\\@ the rest of that \"line\" is
       continued on the next line).

     * Strings concatenated together using @\"...\" + \"...\"@; these
       are concatenated into one big string.
-}
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

-- -----------------------------------------------------------------------------
-- Filtering out unwanted Dot items such as comments

-- | Remove unparseable features of Dot, such as comments and
--   multi-line strings (which are converted to single-line strings).
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)
               -- snd should be null

-- | Parse out comments and make quoted strings spread over multiple
--   lines only over a single line.  Should parse the /entire/ input
--   'Text'.
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
'<'])

-- | Parses an unwanted part of the Dot code (comments and
--   pre-processor lines; also un-splits lines).
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
                      ]

-- | Remove pre-processor lines (that is, those that start with a
--   @#@).  Will consume the newline from the beginning of the
--   previous line, but will leave the one from the pre-processor line
--   there (so in the end it just removes the line).
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

-- | Parse @//@-style comments.
parseLineComment :: (Monoid m) => Parse m
parseLineComment :: forall m. Monoid m => Parse m
parseLineComment = String -> Parse ()
string String
"//"
                   -- Note: do /not/ consume the newlines, as they're
                   -- needed in case the next line is a pre-processor
                   -- line.
                   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

-- | Parse @/* ... */@-style comments.
parseMultiLineComment :: (Monoid m) => Parse m
parseMultiLineComment :: forall m. Monoid m => Parse m
parseMultiLineComment = 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`
                 -- Need to parse an explicit `\', in case it ends the
                 -- string (and thus the next step would get parsed by the
                 -- previous option).
                 (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 -- in case there's a split mid-quote
                 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
'"'

-- | Lines can be split with a @\\@ at the end of the line.
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
'>'