SVG2Q-0.3: main.hs

module Main ( main ) where
import Data.SVG.SVG
import Data.Maybe (catMaybes, fromJust, mapMaybe)
import System( getArgs )
import Text.XML.Light.Types
import Types --my own types
import Translate --my translation functions
import Debug.Trace (trace)
import Data.Generics.Aliases (orElse)
import Helpers (split)
import Data.List (find)
import Color
import Point
import PathCommand (createPathCommands)
import Output (mkImplementation, mkHeader)
import TextElement

main = do
    args <- getArgs
    if or [null args, null (tail args)]
       then 
        putStrLn "usage: svg2q <filename to read svg from> <class name>"
        else do
          contents <- readFile $ head args
          let graphics = map createGraphicsFromContent (extractSVGContent contents)
     --     let code = mapMaybe createCode (catMaybes graphics)
          mkImplementation graphics (args !! 1)
          mkHeader graphics (args!!1)
         -- printCode code 

extractSVGContent :: String -> [Content]
extractSVGContent = elContent . getSVGElement . fromJust . parseSVG

createGraphicsFromContent :: Content -> Maybe GraphicsElement
createGraphicsFromContent (Elem e) = Just $ cgfe e
createGraphicsFromContent _ = Nothing

cgfe :: Element -> GraphicsElement
cgfe e = let name = qName (elName e)
             a = elAttribs e
         in       
         case name of
         "rect" -> Rect (Point (getFloat "x" a) (getFloat "y" a))
                         (getFloat "width" a)
                         (getFloat "height" a)
                         (getFloat "rx" a)
                         (getFloat "ry" a)
                         (getColor (getString "fill" a))
                         (getFloat "stroke-width" a)
                         (getColor (getString "stroke" a))
                         (getId (getString "id" a))
         "circle" -> Circle (Point (getFloat "cx" a) (getFloat "cy" a))
                            (getFloat "r" a)
                            (getColor (getString "fill" a))
                            (getFloat "stroke-width" a)
                            (getColor (getString "stroke" a))
                            (getId (getString "id" a))
         "ellipse" -> Ellipse (Point (getFloat "cx" a) (getFloat "cy" a))       
                              (getFloat "rx" a)
                              (getFloat "ry" a)
                              (getColor (getString "fill" a))
                              (getFloat "stroke-width" a)
                              (getColor (getString "stroke" a))
                              (getId (getString "id" a))
         "line" -> Line (Point (getFloat "x1" a) (getFloat "y1" a))
                         (Point (getFloat "x2" a) (getFloat "y2" a))
                         (getFloat "stroke-width" a)
                         (getColor (getString "stroke" a))
                         (getId (getString "id" a))
         "polyline" -> mkPolyline (getPoints (getString "points" a))
                                (getColor (getString "fill" a))
                                (getFloat "stroke-width" a)
                                (getColor (getString "stroke" a))
                                (getId (getString "id" a))
         "polygon" -> let p = getPoints (getString "points" a) in
                      mkPolyline (p++[head p])
                               (getColor (getString "fill" a))
                               (getFloat "stroke-width" a)
                               (getColor (getString "stroke" a))
                               (getId (getString "id" a))
         "g" -> createGroup e
         "desc" -> createDescription e
         "defs" -> createDefinition e
         "path" -> createPath a
         "text" -> TextElement (TextElem (getText (elContent e))
                                         (getFloat "font-size" a)
                                         (getString "font-family" a)
                                         (Point (getFloat "x" a)
                                                (getFloat "y" a))
                                         (getColor (getString "stroke" a))
                                         (getFloat "stroke-width" a)
                                         (getColor (getString "fill" a)))
                               (getId (getString "id" a))
         -- die on unknown tags, but promt them
         _ -> error $ "unknown tag: "++ name 
         
createGroup :: Element -> GraphicsElement
createGroup e = Group (mapMaybe createGraphicsFromContent (elContent e))
                       (getId (getString "id" (elAttribs e)))

createDescription :: Element -> GraphicsElement
createDescription e = Description

createDefinition :: Element -> GraphicsElement
createDefinition e = Definition

createPath :: [Attr] -> GraphicsElement
createPath a = Path (createPathCommands (getString "d" a))
                    (getId (getString "id" a))
                    (getColor (getString "fill" a))
                    (getFloat "stroke-width" a)
                    (getColor (getString "stroke" a))



kvpFromCSSAttr :: Maybe Attr -> [KeyValuePair]
kvpFromCSSAttr Nothing = []
kvpFromCSSAttr (Just a) = 
               let f = map (g . split ":")
                   g (x:y:[]) = KeyValuePair x y
                   g (x:y:_) = trace ("Warning: too many values for \
                                     \Key "++x++", using "++y)
                                     (KeyValuePair x y)
                   g (x:_) = error ("Error: No value for key "++x)
                   sl = split ";" (attrVal a)
               in
                f sl
                   
getStyleString :: String -> [Attr] -> Maybe String
getStyleString s a = 
               getStringFromKVP
                s 
                (kvpFromCSSAttr (find (\x -> qName (attrKey x) == "style") 
                                      a))

getXMLString :: String -> [Attr] -> Maybe String
getXMLString s l = let sr = (find (\x -> qName (attrKey x) == s) l)
                   in
                        if sr == Nothing
                        then Nothing
                        else Just (attrVal (fromJust sr))

getStyleFloat :: String -> [Attr] -> Maybe Float
getStyleFloat s a = let sr = (getStyleString s a)
                    in
                        if sr == Nothing
                        then Nothing
                        else Just (read (fromJust sr))

getXMLFloat :: String -> [Attr] -> Maybe Float
getXMLFloat s a = let sr = (getXMLString s a)
                  in
                        if sr == Nothing
                        then Nothing
                        else Just (read (fromJust sr))

getString :: String -> [Attr] -> Maybe String
getString s a = let xml = getXMLString s a
                    style = getStyleString s a
                in
                    orElse style xml

getFloat :: String -> [Attr] -> Float
getFloat s a = let xml = getXMLFloat s a
                   style = getStyleFloat s a
                   r = orElse style xml
               in
                   if r == Nothing
                   then if s `elem` ["rx", "ry"]
                        then 0
                        else error ("Error: expected value for key \""++s++"\"\
                              \, but none found.")
                   else fromJust r

getText :: [Content] -> String
getText (Text x:xs) = cdData x
getText (_:xs) = getText xs
getText _ = ""