Convert SVG to Android VectorDrawable in Haskell.

sample.svg

sample.xml

<?xml version="1.0" encoding="utf-8"?>
<vector xmlns:android="http://schemas.android.com/apk/res/android"
    android:width="400px" android:height="400px" android:viewportWidth="400" android:viewportHeight="400">
    <group android:translateX="8.000000" android:translateY="8.000000">
        <path android:fillColor="#4990E2" android:strokeWidth="1" android:pathData="M192,384 C298.038672,384 384,298.038672 384,192 C384,85.961328 298.038672,0 192,0 C85.961328,0 0,85.961328 0,192 C0,298.038672 85.961328,384 192,384 L192,384 Z M192,320 C121.307552,320 64,262.692448 64,192 C64,121.307552 121.307552,64 192,64 C262.692448,64 320,121.307552 320,192 C320,262.692448 262.692448,320 192,320 L192,320 Z"/>
        <path android:fillColor="#D0011B" android:strokeWidth="1" android:pathData="M192,252 L121.46577,289.082039 L134.936609,210.54102 L77.873218,154.917961 L156.732885,143.45898 L192,72 L227.267115,143.45898 L306.126782,154.917961 L249.063391,210.54102 L262.53423,289.082039 L192,252 Z"/>
    </group>
</vector>

svg2vd.hs

import Data.List (intersperse, find)
import Data.Maybe (catMaybes, fromJust)
import Control.Monad (join)
import System.Environment (getArgs)
import Text.Regex
import Text.XML.Light

-- types

type OptAttr = Maybe String

data Vector = Vector String String String String [VectorElement]

data VectorElement =
    Group (Maybe (String, String)) [VectorElement] |
    Path OptAttr OptAttr OptAttr OptAttr OptAttr String

data Indent = Indent Int String

-- functions

vector :: Vector -> [Indent]
vector (Vector width height viewportWidth viewportHeight elems) = [
    Indent 0 "<?xml version=\"1.0\" encoding=\"utf-8\"?>",
    Indent 0 "<vector xmlns:android=\"http://schemas.android.com/apk/res/android\"",
    Indent 1 $ joinStr " " [
        attr "android:width" width,
        attr "android:height" height,
        attr "android:viewportWidth" viewportWidth,
        attr "android:viewportHeight" viewportHeight] ++ ">"] ++
    vectorElements 1 elems ++ [
    Indent 0 "</vector>"]

vectorElements :: Int -> [VectorElement] -> [Indent]
vectorElements n elems = concat $ map (vectorElement n) elems

vectorElement :: Int -> VectorElement -> [Indent]

vectorElement n (Group Nothing elems) = vectorElements n elems

vectorElement n (Group (Just (x, y)) elems) = [
    Indent n $ "<group " ++ joinStr " " [
        attr "android:translateX" x,
        attr "android:translateY" y] ++ ">"] ++
    vectorElements (n + 1) elems ++ [
    Indent n "</group>"]

vectorElement n (Path fillColor strokeColor lineWidth capStyle joinStyle pathData) =
    [Indent n $ "<path " ++ (joinStr " " . catMaybes) [
        optAttr "android:fillColor" fillColor,
        optAttr "android:strokeColor" strokeColor,
        optAttr "android:strokeWidth" lineWidth,
        optAttr "android:strokeLineCap" capStyle,
        optAttr "android:strokeLineJoin" joinStyle,
        Just $ attr "android:pathData" pathData] ++ "/>"]

attr :: String -> String -> String
attr name value = name ++ "=" ++ show value

optAttr :: String -> Maybe String -> Maybe String
optAttr name = fmap $ attr name

indents :: [Indent] -> String
indents = joinStr "\n" . map indent

indent :: Indent -> String
indent (Indent n s) = replicate (n * 4) ' ' ++ s

joinStr :: String -> [String] -> String
joinStr s = concat . intersperse s

-- convert from svg

svg2vd :: Element -> Vector
svg2vd root = Vector width height (viewBox !! 2) (viewBox !! 3) cont
    where width = fromJust $ getAttr "width" root
          height = fromJust $ getAttr "height" root
          viewBox = words $ fromJust $ getAttr "viewBox" root
          cont = convContents [] $ elContent root

convContents :: [Attr] -> [Content] -> [VectorElement]
convContents attrs xs = catMaybes $ map (convContent attrs) xs

convContent :: [Attr] -> Content -> Maybe VectorElement
convContent attrs (Elem e) = case qName (elName e) of
    "g" -> Just $ convGroup attrs e
    "path" -> Just $ convPath attrs e
    _ -> Nothing
convContent _ _ = Nothing

convGroup :: [Attr] -> Element -> VectorElement
convGroup attrs e = Group transform $ convContents combinedAttrs $ elContent e
    where combinedAttrs = elAttribs e ++ attrs
          re = matchRegex $ mkRegex "^translate[(]([0-9.]+), *([0-9.]+)[)]$"
          transform = join $ fmap (\x -> fmap (\[x, y] -> (x, y)) $ re x) $ getAttr "transform" e

convPath :: [Attr] -> Element -> VectorElement
convPath attrs e = Path fillColor strokeColor lineWidth capStyle joinStyle pathData
    where combinedAttrs = elAttribs e ++ attrs
          fillColor = findAttr'' "fill" combinedAttrs
          strokeColor = findAttr'' "stroke" combinedAttrs
          lineWidth = findAttr'' "stroke-width" combinedAttrs
          capStyle = findAttr'' "stroke-linecap" combinedAttrs
          joinStyle = findAttr'' "stroke-linejoin" combinedAttrs
          pathData = fromJust $ getAttr "d" e

getAttr :: String -> Element -> Maybe String
getAttr name = findAttr' name . elAttribs

findAttr' :: String -> [Attr] -> Maybe String
findAttr' name = fmap attrVal . find (\x -> qName (attrKey x) == name)

findAttr'' :: String -> [Attr] -> Maybe String
findAttr'' name attrs = if x == Just "none" then Nothing else x
    where x = findAttr' name attrs

-- main

main :: IO ()
main = do
    args <- getArgs
    xml <- readFile $ head args
    putStrLn $ indents $ vector $ svg2vd $ fromJust $ parseXMLDoc xml