module Graphics.XDot.Parser (
--test,
getOperations,
getDimensions,
getSize
)
where
import Control.Monad
import Data.Maybe
import Data.Char
import Data.Ratio
import Data.Bits
import qualified Data.Foldable as F
import qualified Data.Text.Lazy as B
import qualified Data.Text.Lazy.Read as B
import qualified Text.ParserCombinators.Poly.StateText as P
import Data.GraphViz.Types hiding (parse, attrs)
import Data.GraphViz.Parsing hiding (parse)
import qualified Data.GraphViz.Attributes.Complete as A
import qualified Data.GraphViz.Types.Generalised as G
import Graphics.XDot.Types hiding (w, h, filled, baseline, width, alignment, size, text, xy, name)
getOperations :: G.DotGraph a -> [(Object a, Operation)]
getOperations (G.DotGraph _ _ _ graphStatements) = F.foldr handle [] graphStatements
where handle (G.GA (GraphAttrs attrs)) l = zip (repeat None) (handleInternal attrs) ++ l
handle (G.DN (DotNode ident attrs)) l = zip (repeat $ Node ident) (handleInternal attrs) ++ l
handle (G.DE (DotEdge from to attrs)) l = zip (repeat $ Edge from to) (handleInternal attrs) ++ l
handle (G.SG (G.DotSG _ _ statements)) l = F.foldr handle [] statements ++ l
handle _ l = l
handleInternal attrs = foldr handleFirst [] attrs ++ foldr handleSecond [] attrs
handleFirst (A.UnknownAttribute "_draw_" r) l = parse r ++ l
handleFirst _ l = l
handleSecond (A.UnknownAttribute "_ldraw_" r) l = parse r ++ l
handleSecond (A.UnknownAttribute "_hdraw_" r) l = parse r ++ l
handleSecond (A.UnknownAttribute "_tdraw_" r) l = parse r ++ l
handleSecond (A.UnknownAttribute "_hldraw_" r) l = parse r ++ l
handleSecond (A.UnknownAttribute "_tlldraw_" r) l = parse r ++ l
handleSecond _ l = l
getDimensions :: G.DotGraph a -> [(Object a, Rectangle)]
getDimensions (G.DotGraph _ _ _ graphStatements) = F.foldr handle [] graphStatements
where handle (G.DN (DotNode ident attrs)) l = (Node ident, (x w / 2, y h / 2, w, h)) : l
where (x,y) = foldr getPos (0,0) attrs
w = 72 * foldr getWidth 0 attrs
h = 72 * foldr getHeight 0 attrs
handle (G.DE (DotEdge from to attrs)) l = zip (repeat (Edge from to)) (map (\(x,y) -> (x w / 2, y h / 2, w, h)) xys) ++ l
where xys = foldr getEdgePos [] attrs
w = 30
h = 30
handle _ l = l
getEdgePos (A.Pos (A.SplinePos splines)) l = foldr getSplinePos [] splines ++ l
getEdgePos _ l = l
getSplinePos (A.Spline {A.splinePoints = ((A.Point xStart yStart _ _):_), A.endPoint = Just (A.Point xEnd yEnd _ _)}) l = (xStart, yStart) : (xEnd, yEnd) : l
getSplinePos _ l = l
getWidth (A.Width w) _ = w
getWidth _ l = l
getHeight (A.Height h) _ = h
getHeight _ l = l
getPos (A.Pos (A.PointPos (A.Point x y _ _))) _ = (x,y)
getPos _ l = l
getSize :: G.DotGraph a -> Rectangle
getSize (G.DotGraph _ _ _ graphStatements) = F.foldr handle (0,0,0,0) graphStatements
where handle (G.GA (GraphAttrs attrs)) l = if l /= (0,0,0,0) then l else r
where r = foldr handleInternal (0,0,0,0) attrs
handle _ l = l
handleInternal (A.BoundingBox (A.Rect (A.Point x y _ _) (A.Point w h _ _))) r = if r /= (0,0,0,0) then r else (x,y,w,h)
handleInternal _ l = l
parse :: B.Text -> [Operation]
parse = Data.GraphViz.Parsing.runParser' $ P.many $ do
t <- P.next
character ' '
case t of
'E' -> parseEllipse True
'e' -> parseEllipse False
'P' -> parsePolygon True
'p' -> parsePolygon False
'L' -> parsePolyline
'B' -> parseBSpline False
'b' -> parseBSpline True
't' -> parseFontCharacteristics
'T' -> parseText
'C' -> parseColor True
'c' -> parseColor False
'F' -> parseFont
'S' -> parseStyle
'I' -> parseImage
_ -> fail "Unknown Operation"
where
parseEllipse filled = do
p <- parsePoint
(w,h) <- parsePoint
return $ Ellipse p w h filled
parsePolygon filled = do
xs <- parsePoints
return $ Polygon xs filled
parsePolyline = liftM Polyline parsePoints
parseBSpline filled = do
xs <- parsePoints
return $ BSpline xs filled
parseFontCharacteristics = do
f <- parseInt'
character ' '
return $ FontCharacteristics (testBit f 0) (testBit f 1) (testBit f 2) (testBit f 3) (testBit f 4) (testBit f 5)
parseText = do
baseline <- parsePoint
j <- parseInt'
let alignment = case j of
1 -> LeftAlign
0 -> CenterAlign
1 -> RightAlign
_ -> error "Unexpected alignment"
character ' '
width <- parseFloat'
character ' '
text <- parseString
return $ Text baseline alignment width text
parseFont = do
size <- parseFloat'
character ' '
name <- parseString
return $ Font size name
parseStyle = liftM Style parseString
parseImage = do
xy <- parsePoint
(w,h) <- parsePoint
name <- parseString
return $ Image xy w h name
parseString = do
n <- parseInt
character ' '
character '-'
text <- replicateM (fromInteger n) P.next
character ' '
return text
parsePoints = do
n <- parseInt
character ' '
replicateM (fromInteger n) parsePoint
parsePoint = do
x <- parseFloat'
character ' '
y <- parseFloat'
character ' '
return (x,y)
parseColor filled = do
n <- parseInt
character ' '
character '-'
character '#'
r <- parseHex
g <- parseHex
b <- parseHex
case n of
7 -> do
character ' '
return $ Color (r,g,b,1) filled
9 -> do
a <- parseHex
character ' '
return $ Color (r,g,b,a) filled
_ -> fail "Unknown color encoding"
where parseHex = liftM hexToFloat $ replicateM 2 P.next
hexToFloat s = foldl (\x y -> 16 * x + fromIntegral (digitToInt y)) 0 s / 255
parseSigned p = (character '-' >> liftM negate p)
`P.onFail`
p
parseInt = do cs <- P.many1Satisfy isDigit
case B.decimal cs of
Right (n,"") -> return n
Right (_,txt) -> fail $ "Trailing digits not parsed as Integral: " ++ B.unpack txt
Left err -> fail $ "Could not read Integral: " ++ err
`P.adjustErr` ("Expected one or more digits\n\t"++)
parseInt' = parseSigned parseInt
parseFloat = do ds <- P.manySatisfy isDigit
frac <- P.optional
$ do character '.'
P.manySatisfy isDigit
when (B.null ds && noDec frac)
(fail "No actual digits in floating point number!")
expn <- P.optional parseExp
when (isNothing frac && isNothing expn)
(fail "This is an integer, not a floating point number!")
let frac' = fromMaybe "" frac
expn' = fromMaybe 0 expn
( return . fromRational . (* (10^^(expn' fromIntegral (B.length frac'))))
. (%1) . Data.GraphViz.Parsing.runParser' parseInt) (ds `B.append` frac')
`P.onFail`
fail "Expected a floating point number"
where
parseExp = do character 'e'
(character '+' >> parseInt)
`P.onFail`
parseInt'
noDec = maybe True B.null
parseFloat' = parseSigned ( parseFloat
`onFail`
liftM fI parseInt
)
where
fI :: Integer -> Double
fI = fromIntegral