EncodeJSON.hs

--------------------------------------------------------------------------------
-- |
-- module:    Dialog.EncodeJSON
-- copyright: (c) 2015 Nikita Churaev
-- license:   BSD3
--------------------------------------------------------------------------------

{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE OverloadedStrings #-}

--------------------------------------------------------------------------------

module Dialog.EncodeJSON (
  strJSON,
  paragraphsToJSON,
  formattedTextToJSON,
  pictureSourceToJSON,
  listStyleToJSON,
  cellStyleToJSON,
  colorToJSON
) where

--------------------------------------------------------------------------------

import Data.Monoid ((<>))
import Data.Text (Text)
import Dialog.Internal
import qualified Data.Text.Lazy as TL
import qualified Data.Text.Lazy.Builder as TLB

--------------------------------------------------------------------------------

strJSON :: String -> TL.Text
strJSON string =
  TLB.toLazyText ("\"" <> helper (TLB.fromString "") string <> "\"")
  where
    helper builder [] = builder
    helper builder (x:xs) =
      helper (builder <> repr x) xs
      where
        repr '\"' = "\\\""
        repr '\b' = "\\b"
        repr '\f' = "\\f"
        repr '\n' = "\\n"
        repr '\r' = "\\r"
        repr '\t' = "\\t"
        repr char = TLB.singleton char

arr :: [TL.Text] -> TL.Text
arr list = "[" <> (TL.intercalate ", " list) <> "]" 

obj :: [(TL.Text, TL.Text)] -> TL.Text
obj props =
  "{" <> (TL.intercalate ", " (map makeProperty props)) <> "}"
  where
    makeProperty (key, value) = strJSON (TL.unpack key) <> ": " <> value

typedObj :: TL.Text -> [(TL.Text, TL.Text)] -> TL.Text
typedObj objType props = obj (("type", strJSON (TL.unpack objType)):props)

showTL :: Show a => a -> TL.Text
showTL value = TL.pack (show value) 

--------------------------------------------------------------------------------

paragraphsToJSON :: [Paragraph] -> TL.Text
paragraphsToJSON paragraphs = arr (map paragraphToJSON paragraphs) 

--------------------------------------------------------------------------------

paragraphToJSON :: Paragraph -> TL.Text
paragraphToJSON = \case
  TextParagraph formattedText ->
    typedObj "text" [("text", formattedTextToJSON formattedText)]
  Picture source ->
    typedObj "picture" [("source", pictureSourceToJSON source)]
  List style items ->
    typedObj "list" [
      ("style", listStyleToJSON style),
      ("items", arr (map itemToJSON items))]
    where
      itemToJSON (ListItem paragraphs) = paragraphsToJSON paragraphs
  Table rows -> 
    typedObj "table" [("rows", arr (map handleRow rows))]
    where
      handleRow (TableRow cells) = arr (map handleCell cells)
      handleCell (TableCell style paragraphs) =
        typedObj "cell" [
          ("style", cellStyleToJSON style),
          ("paragraphs", paragraphsToJSON paragraphs)]

--------------------------------------------------------------------------------

formattedTextToJSON :: FormattedText -> TL.Text
formattedTextToJSON = \case
  Plain string ->
    typedObj "plain" [("text", strJSON string)]
  Colored color text ->
    typedObj "colored" [
      ("color", colorToJSON color),
      ("text", formattedTextToJSON text)]
  Bold text ->
    typedObj "bold" [("text", formattedTextToJSON text)]
  Italic text ->
    typedObj "italic" [("text", formattedTextToJSON text)]
  Underline text ->
    typedObj "underline" [("text", formattedTextToJSON text)]
  Size size text ->
    typedObj "size" [
      ("size", showTL size),
      ("text", formattedTextToJSON text)]
  Link url text ->
    typedObj "link" [
      ("url", strJSON url),
      ("text", formattedTextToJSON text)]
  CompositeText parts ->
    typedObj "composite" [
      ("parts", arr (map formattedTextToJSON parts))]

--------------------------------------------------------------------------------

pictureSourceToJSON :: PictureSource -> TL.Text
pictureSourceToJSON = \case
  PictureFromURL url -> typedObj "url" [("url", strJSON url)]

--------------------------------------------------------------------------------

listStyleToJSON :: ListStyle -> TL.Text
listStyleToJSON = \case
  NumberedList -> "\"numbered\""
  BulletList   -> "\"bullet\""

--------------------------------------------------------------------------------

cellStyleToJSON :: CellStyle -> TL.Text
cellStyleToJSON = \case
  NormalCell -> "\"normal\""
  HeaderCell -> "\"header\""

--------------------------------------------------------------------------------

colorToJSON :: Color -> TL.Text
colorToJSON (Color r g b) =
  typedObj "rgb" [("r", showTL r), ("g", showTL g), ("b", showTL b)]

--------------------------------------------------------------------------------