yjsvg 0.2.0.0 → 0.2.0.1
raw patch · 2 files changed
+131/−203 lines, 2 filesdep ~HaXml
Dependency ranges changed: HaXml
Files
- src/Text/XML/YJSVG.hs +129/−201
- yjsvg.cabal +2/−2
src/Text/XML/YJSVG.hs view
@@ -1,49 +1,42 @@ module Text.XML.YJSVG (- showSVG-, SVG(..)-, Transform(..)-, Color(..)-, Position(..), topleft, center-, yjsvgVersion-, Font(..)-, FontWeight(..)+ SVG(..), Position(..), Color(..), Transform(..),+ Font(..), FontWeight(..),+ showSVG, topleft, center, ) where -import Text.XML.HaXml(AttValue(..), QName(..), Prolog(..),+import Text.XML.HaXml(+ AttValue(..), QName(..), Prolog(..), EncodingDecl(..), XMLDecl(..), SystemLiteral(..), PubidLiteral(..), ExternalID(..), DocTypeDecl(..), Misc(..), Element(..), Content(..),- Document(..))-import Text.XML.HaXml.Pretty+ Document(..) )+import Text.XML.HaXml.Pretty (document) import Data.Word(Word8) -yjsvgVersion :: (Int, String)-yjsvgVersion = (9, "0.1.17")- data FontWeight = Normal | Bold deriving (Show, Read)+ weightValue :: FontWeight -> String weightValue Normal = "normal" weightValue Bold = "bold" -data Font = Font{- fontName :: String,- fontWeight :: FontWeight- } deriving (Show, Read)+data Font = Font{ fontName :: String, fontWeight :: FontWeight }+ deriving (Show, Read)+ data Position- = TopLeft{posX :: Double, posY :: Double}- | Center{posX :: Double, posY :: Double}+ = TopLeft { posX :: Double, posY :: Double }+ | Center { posX :: Double, posY :: Double } deriving (Show, Read) topleft, center :: Double -> Double -> Position -> Position-topleft w h Center{posX = x, posY = y} =- TopLeft{posX = x + w / 2, posY = - y + h / 2}+topleft w h Center { posX = x, posY = y } =+ TopLeft { posX = x + w / 2, posY = - y + h / 2 } topleft _ _ pos = pos-center w h TopLeft{posX = x, posY = y} =- Center{posX = x - w / 2, posY = - y + h / 2}+center w h TopLeft { posX = x, posY = y } =+ Center { posX = x - w / 2, posY = - y + h / 2 } center _ _ pos = pos getPos :: Double -> Double -> Position -> (Double, Double)-getPos _ _ TopLeft{posX = x, posY = y} = (x, y)-getPos w h Center{posX = x, posY = y} = (x + w / 2, - y + h / 2)+getPos _ _ TopLeft { posX = x, posY = y } = (x, y)+getPos w h Center { posX = x, posY = y } = (x + w / 2, - y + h / 2) type Id = String @@ -58,30 +51,27 @@ Group [ Transform ] [ (Id,SVG) ] | Defs [ (Id,SVG) ] --Symbol [ (Id,SVG) ]- deriving (Show, Read)+ data Color- = ColorName{- colorName :: String- }- | RGB {- colorRed :: Word8,+ = ColorName{ colorName :: String }+ | RGB { colorRed :: Word8, colorGreen :: Word8,- colorBlue :: Word8- }+ colorBlue :: Word8 } deriving (Eq, Show, Read) mkColorStr :: Color -> String-mkColorStr ColorName{colorName = n} = n-mkColorStr RGB{colorRed = r, colorGreen = g, colorBlue = b} =+mkColorStr ColorName { colorName = n } = n+mkColorStr RGB { colorRed = r, colorGreen = g, colorBlue = b } = "rgb(" ++ show r ++ "," ++ show g ++ "," ++ show b ++ ")" -data Transform = Matrix Double Double Double Double Double Double |- Translate Double Double |- Scale Double Double |- Rotate Double (Maybe (Double, Double)) |- SkewX Double |- SkewY Double+data Transform+ = Matrix Double Double Double Double Double Double+ | Translate Double Double+ | Scale Double Double+ | Rotate Double (Maybe (Double, Double))+ | SkewX Double+ | SkewY Double deriving (Show, Read) showTrans :: Transform -> String@@ -90,186 +80,124 @@ showTrans (SkewX s) = "skewX(" ++ show s ++ ") " showTrans (SkewY s) = "skewY(" ++ show s ++ ") " showTrans (Rotate s _) = "rotate(" ++ show s ++ ") "-showTrans (Matrix a b c d e f) = "matrix(" ++ show a ++ "," ++ show b ++ "," ++ show c ++ "," ++ show d ++ "," ++ show e ++ "," ++ show f ++ ") "-+showTrans (Matrix a b c d e f) = "matrix(" +++ show a ++ "," ++ show b ++ "," ++ show c ++ "," +++ show d ++ "," ++ show e ++ "," ++ show f ++ ") " -- showTrans _ = error "not implemented yet" showSVG :: Double -> Double -> [ (Id, SVG) ] -> String showSVG w h = show . document . svgToXml w h svgToElem :: Double -> Double -> (Id, SVG) -> Element ()-svgToElem pw ph (idn, (Line p1 p2 color lineWidth))- = Elem (N "line") [- ( N "id", AttValue [ Left $ idn ] )- , ( N "x1", AttValue [ Left $ show x1 ] )- , ( N "y1", AttValue [ Left $ show y1 ] )- , ( N "x2", AttValue [ Left $ show x2 ] )- , ( N "y2", AttValue [ Left $ show y2 ] )- , ( N "stroke", AttValue [ Left $ mkColorStr color ] )- , ( N "stroke-width", AttValue [ Left $ show lineWidth ] )- , (N "stroke-linecap", AttValue [Left "round"])- ] []+svgToElem pw ph (idn, (Line p1 p2 color lineWidth)) = Elem (N "line") [+ (N "id", AttValue [Left idn]),+ (N "x1", AttValue [Left $ show x1]),+ (N "y1", AttValue [Left $ show y1]),+ (N "x2", AttValue [Left $ show x2]),+ (N "y2", AttValue [Left $ show y2]),+ (N "stroke", AttValue [Left $ mkColorStr color]),+ (N "stroke-width", AttValue [Left $ show lineWidth]),+ (N "stroke-linecap", AttValue [Left "round"]) ] [] where (x1, y1) = getPos pw ph p1 (x2, y2) = getPos pw ph p2--svgToElem pw ph (idn, (Polyline points fillColor lineColor lineWidth))- = Elem (N "polyline") [- ( N "id", AttValue [ Left $ idn ] )- , ( N "points", AttValue [ Left $ pointsToAttVal points ] )- , ( N "fill" , AttValue [ Left $ mkColorStr fillColor ] )- , ( N "stroke", AttValue [ Left $ mkColorStr lineColor ] )- , ( N "stroke-width", AttValue [ Left $ show lineWidth ] )- ] []- where- pointsToAttVal :: [Position] -> String- pointsToAttVal [] = ""- pointsToAttVal (p : ps)- = let (x, y) = getPos pw ph p in- show x ++ "," ++ show y ++ " " ++ pointsToAttVal ps--svgToElem pw ph (idn, (Rect p w h sw cf cs))- = Elem (N "rect") [- ( N "id", AttValue [ Left $ idn ] )- , ( N "x", AttValue [ Left $ show x ] )- , ( N "y", AttValue [ Left $ show y ] )- , ( N "width", AttValue [ Left $ show w ] )- , ( N "height", AttValue [ Left $ show h ] )- , ( N "stroke-width", AttValue [ Left $ show sw ] )- , ( N "fill", AttValue [ Left $ mkColorStr cf ] )- , ( N "stroke", AttValue [ Left $ mkColorStr cs ] )- ] []- where- (x, y) = getPos pw ph p--svgToElem pw ph (idn, (Fill c))- = svgToElem pw ph $ (idn, Rect (TopLeft 0 0) pw ph 0 c c)--svgToElem pw ph (idn, (Text p s c f t))- = Elem (N "text") [- ( N "id", AttValue [ Left $ idn ] )- , ( N "x", AttValue [ Left $ show x ] )- , ( N "y", AttValue [ Left $ show y ] )- , ( N "font-family", AttValue [ Left $ fontName f ] )- , ( N "font-weight", AttValue [ Left $ weightValue $ fontWeight f ] )- , ( N "font-size", AttValue [ Left $ show s ] )- , ( N "fill", AttValue [ Left $ mkColorStr c ] )- ] [ CString False (escape t) () ]- where- (x, y) = getPos pw ph p--svgToElem pw ph (idn, (Circle p r c))- = Elem (N "circle") [- ( N "id", AttValue [ Left $ idn ] )- , ( N "cx", AttValue [ Left $ show x ] )- , ( N "cy", AttValue [ Left $ show y ] )- , ( N "r", AttValue [ Left $ show r ] )- , ( N "fill", AttValue [ Left $ mkColorStr c ] )- ] []- where- (x, y) = getPos pw ph p--svgToElem pw ph (idn, (Image p w h path))- = Elem (N "image") [- ( N "id", AttValue [ Left $ idn ] )- , ( N "x", AttValue [ Left $ show x ] )- , ( N "y", AttValue [ Left $ show y ] )- , ( N "width", AttValue [ Left $ show w ] )- , ( N "height", AttValue [ Left $ show h ] )- , ( N "xlink:href", AttValue [ Left path ] )- ] []- where- (x, y) = getPos pw ph p--svgToElem pw ph (_idn, (Use p w h path))- = Elem (N "use") [- ( N "x", AttValue [ Left $ show x ] )- , ( N "y", AttValue [ Left $ show y ] )- , ( N "width", AttValue [ Left $ show w ] )- , ( N "height", AttValue [ Left $ show h ] )- , ( N "xlink:href", AttValue [ Left ("url(#"++path++")") ] )- ] []+svgToElem pw ph (idn, (Polyline points fillColor lineColor lineWidth)) =+ Elem (N "polyline") [+ (N "id", AttValue [ Left $ idn ]),+ (N "points", AttValue [ Left $ pointsToAttVal points ]),+ (N "fill" , AttValue [ Left $ mkColorStr fillColor ]),+ (N "stroke", AttValue [ Left $ mkColorStr lineColor ]),+ (N "stroke-width", AttValue [ Left $ show lineWidth ]) ] [] where- (x, y) = getPos pw ph p--svgToElem pw ph (_idn, (Group trs svgs))- = Elem (N "g") - [ ( N "transform", AttValue (map Left (map showTrans trs))) ]- $ map (flip CElem () . svgToElem pw ph) svgs--svgToElem pw ph (_idn, (Defs svgs))- = Elem (N "defs") - [] (map (flip CElem () . svgToElem pw ph) svgs)----svgToElem pw ph (id, (Symbol svgs))--- = Elem (N "symbol") --- [] (map (flip CElem () . svgToElem pw ph) svgs)+ pointsToAttVal :: [Position] -> String+ pointsToAttVal [] = ""+ pointsToAttVal (p : ps) = let (x, y) = getPos pw ph p in+ show x ++ "," ++ show y ++ " " ++ pointsToAttVal ps+svgToElem pw ph (idn, (Rect p w h sw cf cs)) = Elem (N "rect") [+ (N "id", AttValue [Left $ idn]),+ (N "x", AttValue [Left $ show x]),+ (N "y", AttValue [Left $ show y]),+ (N "width", AttValue [Left $ show w]),+ (N "height", AttValue [Left $ show h]),+ (N "stroke-width", AttValue [Left $ show sw]),+ (N "fill", AttValue [Left $ mkColorStr cf]),+ (N "stroke", AttValue [Left $ mkColorStr cs]) ] []+ where (x, y) = getPos pw ph p+svgToElem pw ph (idn, (Fill c)) =+ svgToElem pw ph $ (idn, Rect (TopLeft 0 0) pw ph 0 c c)+svgToElem pw ph (idn, (Text p s c f t)) = Elem (N "text") [+ (N "id", AttValue [Left $ idn]),+ (N "x", AttValue [Left $ show x]),+ (N "y", AttValue [Left $ show y]),+ (N "font-family", AttValue [Left $ fontName f]),+ (N "font-weight", AttValue [Left $ weightValue $ fontWeight f]),+ (N "font-size", AttValue [Left $ show s]),+ (N "fill", AttValue [Left $ mkColorStr c]) ]+ [CString False (escape t) ()]+ where (x, y) = getPos pw ph p+svgToElem pw ph (idn, (Circle p r c)) = Elem (N "circle") [+ (N "id", AttValue [Left $ idn]),+ (N "cx", AttValue [Left $ show x]),+ (N "cy", AttValue [Left $ show y]),+ (N "r", AttValue [Left $ show r]),+ (N "fill", AttValue [Left $ mkColorStr c]) ] []+ where (x, y) = getPos pw ph p+svgToElem pw ph (idn, (Image p w h path)) = Elem (N "image") [+ (N "id", AttValue [Left $ idn]),+ (N "x", AttValue [Left $ show x]),+ (N "y", AttValue [Left $ show y]),+ (N "width", AttValue [Left $ show w]),+ (N "height", AttValue [Left $ show h]),+ (N "xlink:href", AttValue [Left path]) ] []+ where (x, y) = getPos pw ph p+svgToElem pw ph (_idn, (Use p w h path)) = Elem (N "use") [+ (N "x", AttValue [Left $ show x]),+ (N "y", AttValue [Left $ show y]),+ (N "width", AttValue [Left $ show w]),+ (N "height", AttValue [Left $ show h]),+ (N "xlink:href", AttValue [Left ("url(#"++path++")")]) ] []+ where (x, y) = getPos pw ph p+svgToElem pw ph (_idn, (Group trs svgs)) = Elem (N "g") + [(N "transform", AttValue (map Left (map showTrans trs)))]+ $ map (flip CElem () . svgToElem pw ph) svgs+svgToElem pw ph (_idn, (Defs svgs)) = Elem (N "defs") []+ $ map (flip CElem () . svgToElem pw ph) svgs+-- svgToElem pw ph (id, (Symbol svgs)) = Elem (N "symbol") []+-- $ map (flip CElem () . svgToElem pw ph) svgs svgToXml :: Double -> Double -> [ (Id,SVG) ] -> Document ()-svgToXml w h svgs- = Document prlg ent- (Elem (N "svg") (emAtt w h) $ map (flip CElem () . svgToElem w h) svgs) els+svgToXml w h svgs = Document prlg [] (Elem (N "svg") (emAtt w h)+ $ map (flip CElem () . svgToElem w h) svgs) [] pmsc :: [Misc]-pmsc = [ Comment " MADE BY SVG.HS " ]+pmsc = [ Comment " MADE BY SVG.HS " ]+ pblit, sslit :: String-pblit = "-//W3C//DTD SVG 1.1//EN"-sslit = "http://www.w3.org/Graphics/SVG/1.1/DTD/svg11.dtd"+pblit = "-//W3C//DTD SVG 1.1//EN"+sslit = "http://www.w3.org/Graphics/SVG/1.1/DTD/svg11.dtd"+ doctype :: DocTypeDecl-doctype = DTD (N "svg") (Just (PUBLIC (PubidLiteral pblit) (SystemLiteral sslit))) []+doctype = DTD (N "svg")+ (Just (PUBLIC (PubidLiteral pblit) (SystemLiteral sslit))) []+ xmldcl :: XMLDecl-xmldcl = XMLDecl "1.0" (Just (EncodingDecl "UTF-8")) Nothing+xmldcl = XMLDecl "1.0" (Just (EncodingDecl "UTF-8")) Nothing+ prlg :: Prolog-prlg = Prolog (Just xmldcl) pmsc (Just doctype) []+prlg = Prolog (Just xmldcl) pmsc (Just doctype) [] xmlns, ver, xlink :: String-xmlns = "http://www.w3.org/2000/svg"-ver = "1.1"-xlink = "http://www.w3.org/1999/xlink"-emAtt :: (Show a, Show b) => a -> b -> [(QName, AttValue)]-emAtt w h = [- ( N "xmlns", AttValue [ Left xmlns ] )- , ( N "version", AttValue [ Left ver ] )- , ( N "xmlns:xlink", AttValue [ Left xlink ] )- , ( N "width", AttValue [ Left $ show w ] )- , ( N "height", AttValue [ Left $ show h ] )- ]-ent, els :: [a]-ent = []-els = []-{--height, width :: String-width = "400"-height = "640"-em :: CharData -> Element ()-em ougon= Elem (N "svg") (emAtt (100 :: Int) (200 :: Int)) [ CElem rect (), CElem (text ougon) () ]-rect :: Element i-rect = Elem (N "rect") [- ( N "x", AttValue [ Left "20" ] )- , ( N "y", AttValue [ Left "30" ] )- , ( N "width", AttValue [ Left "80" ] )- , ( N "height", AttValue [ Left "100" ] )- , ( N "fill", AttValue [ Left "red" ] )- , ( N "stroke", AttValue [ Left "none" ] )- ] []-text :: CharData -> Element ()-text ougon = Elem (N "text") [- ( N "x", AttValue [ Left "20" ] )- , ( N "y", AttValue [ Left "50" ] )- , ( N "font-size", AttValue [ Left "20" ] )- ] [ CString False ougon () ]---- els = [ Comment "MADE BY SIMPLE.HS" ]--docu :: CharData -> Document ()-docu ougon = Document prlg ent (em ougon) els+xmlns = "http://www.w3.org/2000/svg"+ver = "1.1"+xlink = "http://www.w3.org/1999/xlink" -svgMain = do- ougonXml <- readFile "ougon.xml"- let Document _ _ (Elem "text" _ [ CString _ ougon _ ]) _- = xmlParse "ougon.xml" ougonXml- print $ document $ svgToXml 100 200 [ Rect 20 30 80 90 "black" "purple", Text 40 50 30 "underline" "purple" "good" ]--}+emAtt :: (Show a, Show b) => a -> b -> [(QName, AttValue)]+emAtt w h = [+ (N "xmlns", AttValue [Left xmlns]),+ (N "version", AttValue [Left ver]),+ (N "xmlns:xlink", AttValue [Left xlink]),+ (N "width", AttValue [Left $ show w]),+ (N "height", AttValue [Left $ show h]) ] escape :: String -> String escape "" = ""
yjsvg.cabal view
@@ -2,7 +2,7 @@ Cabal-Version: >= 1.8 Name: yjsvg-Version: 0.2.0.0+Version: 0.2.0.1 stability: experimental author: YoshikuniJujo <PAF01143@nifty.ne.jp> maintainer: YoshikuniJujo <PAF01143@nifty.ne.jp>@@ -30,5 +30,5 @@ Library Hs-source-dirs: src Exposed-Modules: Text.XML.YJSVG- Build-Depends: base == 4.*, HaXml == 1.24.*+ Build-Depends: base == 4.*, HaXml == 1.25.* Ghc-Options: -Wall -fno-warn-tabs