ToJson.hs

module Operations.ToJson (ToJson(..)) where

import Parser            (runParser)
import ParserCombinators (IsMatch (..), maybeWithin, (<|>), (|*))
import Parsers.Json      (json)
import Parsers.String    (spacing)
import SyntaxTrees.Json  (JsExpression (..))
import SyntaxTrees.Toml  (TomlExpression (..))
import SyntaxTrees.Xml   (XmlExpression (..))
import SyntaxTrees.Yaml  (YamlExpression (..))

import           Data.Either (fromRight)
import           Data.Map    (Map, elems)
import qualified Data.Map    as Map


class ToJson a where
  toJson :: a -> JsExpression


instance {-# OVERLAPPABLE #-} ToJson JsExpression where
  toJson = id

instance ToJson XmlExpression where

  toJson XmlExpression { tagName = tag, expressions = exprs, .. }
    | tag == "literal"  = fromRight JsNull . runParser literalParser .
                              head . elems $ fields
    | tag == "array"    = JsArray $ childExprToJson <$> exprs
    | tag == "object"   = JsObject . Map.fromList $ (\x -> (tagName x, childExprToJson x)) <$>
                                        exprs
    | otherwise          = JsNull   where

        literalParser = json <|> (JsString <$> maybeWithin spacing (isNot '<' |*))

        childExprToJson = toJson . head . (expressions)


instance ToJson YamlExpression where

  toJson = \case
    YamlNull              -> JsNull
    YamlInteger n         -> JsNumber $ fromIntegral n
    YamlFloat n           -> JsNumber n
    YamlBool bool         -> JsBool bool
    YamlString str        -> JsString str
    YamlDate date         -> JsString $ show date
    YamlTime time         -> JsString $ show time
    YamlDateTime dateTime -> JsString $ show dateTime
    YamlList _ list       -> JsArray $ toJson <$> list
    YamlMap  _ mapping    -> JsObject $ toJson <$> mapping


instance ToJson TomlExpression where

  toJson = \case
    TomlNull              -> JsNull
    TomlInteger n         -> JsNumber $ fromIntegral n
    TomlFloat n           -> JsNumber n
    TomlBool bool         -> JsBool bool
    TomlString str        -> JsString str
    TomlDate date         -> JsString $ show date
    TomlTime time         -> JsString $ show time
    TomlDateTime dateTime -> JsString $ show dateTime
    TomlArray list        -> JsArray $ toJson <$> list
    TomlTable _ mapping   -> JsObject $ toJson <$> mapping



instance ToJson String where
  toJson = JsString

instance ToJson Char where
  toJson = JsString . pure

instance ToJson Int where
  toJson = JsNumber . fromIntegral

instance ToJson Integer where
  toJson = JsNumber . fromIntegral

instance ToJson Double where
  toJson = JsNumber

instance ToJson Bool where
  toJson = JsBool

instance ToJson a => ToJson [a] where
  toJson = JsArray . fmap toJson

instance ToJson a => ToJson (Map String a) where
  toJson = JsObject . fmap toJson

instance ToJson a => ToJson (Maybe a) where
  toJson = maybe JsNull toJson