YAML.hs

module Util.YAML where

import Data.Char
import qualified Data.Map as M
import qualified Data.Set as S

data Node = Leaf String | List [Node] | Map [(String,Node)] | Null

class MapKey a where
    showMapKey :: a -> String

instance MapKey String where
    showMapKey s = s

class ToNode a where
    toNode :: a -> Node

instance ToNode Node where
    toNode x = x

instance ToNode String where
    toNode s = Leaf s

instance ToNode a => ToNode [a] where
    toNode ns = List (map toNode ns)

instance (MapKey k,ToNode a) => ToNode [(k,a)] where
    toNode ns = Map [ (showMapKey x,toNode y) | (x,y) <- ns ]

instance (MapKey k,ToNode b) => ToNode (M.Map k b) where
    toNode mp = Map [(showMapKey x, toNode y) | (x,y) <- M.toList mp]

instance ToNode a => ToNode (S.Set a) where
    toNode st = List $ map toNode (S.toList st)

instance ToNode a => ToNode (Maybe a) where
    toNode Nothing = Null
    toNode (Just x) = toNode x

instance (ToNode a,ToNode b) => ToNode (Either a b) where
    toNode (Left  x) = toNode x
    toNode (Right x) = toNode x

instance ToNode Bool where
    toNode True  = Leaf "true"
    toNode False = Leaf "false"

instance ToNode () where
    toNode () = Null

dumpNode :: Node -> String
dumpNode n = f False 0 n "\n" where
    f nn  i Null     = ns nn . showString "null"
    f nn  i (Leaf x) = ns nn . showString' x
    f nn i (List ns) = nl nn [ g i . showString "-" . f True (i + 1) n | n <- ns ]
    f nn i (Map  ns) = nl nn [ g i . showString x . showString ":" . f True (i + 1) y | (x,y) <- ns ]
    g i = showString $ replicate i ' '
    nl nn [] = id
    nl nn xs = (if nn then ('\n':) else id) . foldr1 (\x y -> x . showChar '\n' . y ) xs
    ns True  = showChar ' '
    ns False = id

showYAML :: ToNode a => a -> String
showYAML n = dumpNode (toNode n)

showString' x y = if all isGood x then x ++ y else '"':f x y where
    f [] y = '"':y
    f (x:xs) ys |  isQuoteGood x = x:f xs ys
                | otherwise  = '\\':x:f xs ys
    isGood x = isAlphaNum x || x `elem` "_-.@/"
    isQuoteGood x = isGood x || isSpace x || x `elem` "!@#$%^&*(){}/"