Convert Haskell datatypes to XML using their ToJSON instance

ToXML.hs

{-# LANGUAGE ApplicativeDo #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE ViewPatterns #-}

import Data.Aeson (ToJSON, Value(..), eitherDecode, toJSON)
import Data.Aeson.Key (toString)
import Data.Aeson.KeyMap (fromList, toAscList)
import Data.Char (isAlpha)
import Data.Foldable (traverse_)
import Options.Applicative
import System.Exit (die)
import Text.Blaze
import Text.Blaze.Internal (customParent)
import Text.Blaze.Renderer.Utf8 (renderMarkup)

import qualified Data.ByteString.Lazy.Char8 as L
import qualified System.Console.Terminal.Size as TS

data Options = Options
  { optUnwrapArrays :: Bool
  , optRootElementName :: String
  , optFile :: FilePath
  } deriving (Show)

main :: IO ()
main = do

  cols <- maybe 100 TS.width <$> TS.size

  Options {..} <- customExecParser
    ( prefs $ columns cols )
    ( info
      ( helper <*> do
          optUnwrapArrays <- switch $
            short 'u' <> long "unwrap-arrays" <>
            help "Represent arrays as repeated instances of their parent element"
          optRootElementName <- strOption $
            short 'r' <> long "root" <> metavar "NAME" <> value "root" <>
            help "The name to be used for the root element" <> showDefaultWith id
          optFile <- strArgument $
            metavar "FILE" <> value "/dev/stdin" <>
            help "The file to be converted" <> showDefaultWith id
          pure Options{..}
      )
      ( fullDesc <> header "Convert JSON to XML" )
    )

  v <- either die pure . eitherDecode @Value =<< L.readFile optFile

  let encode = if optUnwrapArrays then encodeXML' else encodeXML

  L.putStrLn $ encode optRootElementName v

encodeXML :: ToJSON a => String -> a -> L.ByteString
encodeXML root = renderMarkup . toXML root . toJSON

toXML :: String -> Value -> Markup
toXML (customElement . sanitize -> e) = \case
  String t -> e $ toMarkup t
  Number n -> e ! customAttribute "type" "number" $ toMarkup (show n)
  Bool b -> e ! customAttribute "type" "bool" $ toMarkup b
  Null -> e ! customAttribute "type" "null" $ mempty
  Object o -> e $ traverse_ (\(k, v) -> toXML (toString k) v) $ toAscList o
  Array v -> e $ traverse_ (toXML "item") v

encodeXML' :: ToJSON a => String -> a -> L.ByteString
encodeXML' root a = renderMarkup . toXML' root $
  case toJSON a of
    arr@(Array _) -> Object $ fromList [("item", arr)]
    val -> val

toXML' :: String -> Value -> Markup
toXML' parent val = do
  let e = customElement $ sanitize parent
  case val of
    Object o -> e $ traverse_ (\(k, v) -> toXML' (toString k) v) $ toAscList o
    Array v -> traverse_ (toXML' parent) v
    _ -> toXML parent val

customElement :: String -> Markup -> Markup
customElement = customParent . stringTag

-- TODO: Improve this
sanitize :: String -> String
sanitize = map (\c -> if not (isAlpha c) then '_' else c)