--
-- Copyright (c) 2010 Anders Lau Olsen.
-- See LICENSE file for terms and conditions.
--

-- | Parser for the FIG format.
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

----------------------------------------------------------------------
-- Type declarations of exported functions
----------------------------------------------------------------------

-- | Parse a string in the FIG format.
parse
    :: FilePath -- ^Name of the input file (to use in error messages).
    -> String -- ^String in FIG format.
    -> Either String Fig
    -- ^Error message if failed parse; figure if successful parse.

----------------------------------------------------------------------
-- The parser
----------------------------------------------------------------------

parse file str =
    case P.parse fig file str of
        Left err -> Left (show err)
        Right fig -> Right fig

----------------------------------------------------------------------
-- Fig
----------------------------------------------------------------------

fig = do
    h <- header
    cls <- colors
    objs <- objects
    eof
    return (Fig h cls objs)

----------------------------------------------------------------------
-- Header
----------------------------------------------------------------------

header = do
    reserved header_version
    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)

-- The two-word string "Flush Left" requires special treatment.
justification =
    translate "Center" Center <||>
    translate "Flush Left" FlushLeft <||>
    translate "Flush left" FlushLeft -- Some people use lower case.
    where
    translate str value = reserved str >> return value

----------------------------------------------------------------------
-- Comments
----------------------------------------------------------------------

commented obj = try (liftM2 Comment comments obj)

comments = many commentLine

commentLine = lexeme $ do
    string begin_comment
    str <- many (noneOf "\n")
    char '\n'
    return str

----------------------------------------------------------------------
-- Colors
----------------------------------------------------------------------

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)

----------------------------------------------------------------------
-- Objects
----------------------------------------------------------------------

object =
    arcObject <|>
    ellipseObject <|>
    polylineObject <|>
    splineObject <|>
    textObject <|>
    compoundObject

objects = many (commented object)

----------------------------------------------------------------------
-- Compound
----------------------------------------------------------------------

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)

----------------------------------------------------------------------
-- Arc
----------------------------------------------------------------------

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

----------------------------------------------------------------------
-- Text
----------------------------------------------------------------------

textObject = do
    reserved begin_text
    t1 <- integer
    t2 <- colorSpec
    [t3, t4, t5] <- count 3 integer
    t6 <- float
    t7 <- float
    (t8, ps) <- convert toFontFlags integer
    -- the error message positions will be wrong.
    t5' <- convert (toFont ps) (return t5)
    t9 <- float
    t10 <- float
    t11 <- integer
    t12 <- integer' -- white space at the beginning of the text string
    space           -- must be preserved.
    t13 <- textString
    return (Text t1 t2 t3 t4 t5' t6 t7 t8 t9 t10 t11 t12 t13)

textString = manyTill anyChar (reserved "\\001")

----------------------------------------------------------------------
-- Ellipse
----------------------------------------------------------------------

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)

----------------------------------------------------------------------
-- Polyline
----------------------------------------------------------------------

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

----------------------------------------------------------------------
-- Spline
----------------------------------------------------------------------

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)

----------------------------------------------------------------------
-- The 9 fields common for arcs, ellipses, polylines, and splines.
----------------------------------------------------------------------

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)

----------------------------------------------------------------------
-- Utility parsers for cap-style and color specifications
----------------------------------------------------------------------

capStyle = convert toCapStyle integer

colorSpec = convert toColorSpec integer

----------------------------------------------------------------------
-- Utilities
----------------------------------------------------------------------

(<||>) 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 -- P.float does not parse negative floats!
    sign <- do lexeme (do char '-' ; return (- 1)) <|> return 1
    num <- P.float tokenParser <||> liftM fromInteger integer
    return (sign * num)

-- An integer parser that doesn't eat the space following the digits.
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