module Graphics.Fig.Parser (parse) where
import Graphics.Fig.Syntax
import Graphics.Fig.Values
import Control.Monad
import Data.Char
import Text.ParserCombinators.Parsec hiding (count, parse)
import qualified Text.ParserCombinators.Parsec as P
import qualified Text.ParserCombinators.Parsec.Language as P
import qualified Text.ParserCombinators.Parsec.Token as P
parse
:: FilePath
-> String
-> Either String Fig
parse file str =
case P.parse fig file str of
Left err -> Left (show err)
Right fig -> Right fig
fig = do
h <- header
cls <- colors
objs <- objects
eof
return (Fig h cls objs)
header = do
versionLine
h1 <- convert toOrientation identifier
h2 <- justification
h3 <- convert toUnits identifier
h4 <- convert toPaperSize identifier
h5 <- float
h6 <- convert toMultiplePage identifier
h7 <- convert toTransparent integer
h8 <- many commentLine
h9 <- integer
h10 <- convert toCoordinateSystem integer
return (Header h1 h2 h3 h4 h5 h6 h7 h8 h9 h10)
versionLine = do
string header_version
many (noneOf "\n")
char '\n'
justification =
translate "Center" Center <||>
translate "Flush Left" FlushLeft <||>
translate "Flush left" FlushLeft
where
translate str value = reserved str >> return value
commented obj = try (liftM2 Comment comments obj)
comments = many commentLine
commentLine = lexeme $ do
string begin_comment
str <- many (noneOf "\n")
char '\n'
return str
color = do
reserved begin_color
c1 <- integer
c2 <- rgb
return (Color c1 c2)
rgb = lexeme $ do
char '#'
rest <- count 6 hexDigit
notFollowedBy (satisfy (not . isSpace))
return ('#' : rest)
colors = many (commented color)
object =
arcObject <|>
ellipseObject <|>
polylineObject <|>
splineObject <|>
textObject <|>
compoundObject
objects = many (commented object)
compoundObject = do
compound <- compoundLine
objs <- objects
reserved end_compound
return (Compound compound objs)
compoundLine = do
reserved begin_compound
[c1, c2, c3, c4] <- count 4 integer
return (CompoundLine c1 c2 c3 c4)
arcObject = do
(arc, fw, bw) <- arcLine
fwa <- maybeArrow fw
bwa <- maybeArrow bw
return (Arc arc fwa bwa)
arcLine = do
reserved begin_arc
common <- commonLine
a10 <- capStyle
[a11, fw, bw] <- count 3 integer
[a14, a15] <- count 2 float
[a16, a17, a18, a19, a20, a21] <- count 6 integer
return
( ArcLine common a10 a11 a14 a15 a16 a17 a18 a19 a20 a21
, fw
, bw
)
arrow = do
a1 <- convert toArrowType integer
a2 <- convert toArrowStyle integer
[a3, a4, a5] <- count 3 float
return (Arrow a1 a2 a3 a4 a5)
maybeArrow n = if n == 1 then liftM Just arrow else return Nothing
textObject = do
reserved begin_text
t1 <- integer
t2 <- colorSpec
[t3, t4, t5] <- count 3 integer
t6 <- float
t7 <- float
(t8, ps) <- convert toFontFlags integer
t5' <- convert (toFont ps) (return t5)
t9 <- float
t10 <- float
t11 <- integer
t12 <- integer'
space
t13 <- textString
return (Text t1 t2 t3 t4 t5' t6 t7 t8 t9 t10 t11 t12 t13)
textString = manyTill anyChar (reserved "\\001")
ellipseObject = do
reserved begin_ellipse
common <- commonLine
e10 <- integer
e11 <- float
[e12, e13, e14, e15, e16, e17, e18, e19] <- count 8 integer
return (Ellipse common e10 e11 e12 e13 e14 e15 e16 e17 e18 e19)
polylineObject = do
(polyline, fw, bw, npoints) <- polylineLine
fwa <- maybeArrow fw
bwa <- maybeArrow bw
pic <- maybePic (sub_type (polyline_common polyline))
pts <- count npoints point
return (Polyline polyline fwa bwa pic pts)
polylineLine = do
reserved begin_polyline
common <- commonLine
p10 <- convert toJoinStyle integer
p11 <- capStyle
[p12, fw, bw, npoints] <- count 4 integer
return (PolylineLine common p10 p11 p12, fw, bw, npoints)
point = liftM2 (,) integer integer
maybePic n = if n == 5 then liftM Just pic else return Nothing
pic = liftM2 Pic (convert toFlipped integer) identifier
splineObject = do
(spline, fw, bw, npoints) <- splineLine
fwa <- maybeArrow fw
bwa <- maybeArrow bw
pts <- count npoints point
ctrl <- count npoints float
return (Spline spline fwa bwa pts ctrl)
splineLine = do
reserved begin_spline
common <- commonLine
s10 <- capStyle
[fw, bw, npoints] <- count 3 integer
return (SplineLine common s10, fw, bw, npoints)
commonLine = do
t1 <- integer
t2 <- convert toLineStyle integer
t3 <- integer
[t4, t5] <- count 2 colorSpec
[t6, t7] <- count 2 integer
t8 <- convert toAreaFill integer
t9 <- float
return (Common t1 t2 t3 t4 t5 t6 t7 t8 t9)
capStyle = convert toCapStyle integer
colorSpec = convert toColorSpec integer
(<||>) p q = try p <|> q
count n p = P.count (fromIntegral n) p
tokenParser =
P.makeTokenParser
P.emptyDef
{ P.identStart = satisfy (not . isSpace)
, P.identLetter = satisfy (not . isSpace)
}
integer = P.integer tokenParser
lexeme = P.lexeme tokenParser
reserved = P.reserved tokenParser
identifier = P.identifier tokenParser
float = do
sign <- do lexeme (do char '-' ; return ( 1)) <|> return 1
num <- P.float tokenParser <||> liftM fromInteger integer
return (sign * num)
integer' = do
sign <- lexeme (do char '-' ; return "-") <|> return ""
rest <- many1 digit
return (read (sign ++ rest) :: Integer)
convert to reader = do
p <- getPosition
val <- liftM to reader
either
(\e -> fail (show p ++ ":\n" ++ e))
return
val