{-# LANGUAGE TupleSections, DeriveGeneric, OverloadedStrings, CPP #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Sugar.Json
  ( SugarCube(..)
  , sugarCubeMay
  , writeJsonAsSugarBinary
  , writeJsonAsSugar
  ) where

import Data.Text (Text)
import Data.Map (Map)
import Data.Scientific (floatingOrInteger)
import TextShow (showt)

import qualified Data.Map as Map

#if MIN_VERSION_aeson(2,0,0)
import qualified Data.Aeson.Key as AesonKey
import qualified Data.Aeson.KeyMap as KeyMap
#else
import qualified Data.HashMap.Strict as KeyMap
#endif

import qualified Data.Serialize as Serialize
import qualified Data.ByteString as BS
import qualified Data.ByteString.Lazy as BL
import qualified Data.Aeson as Json
import qualified Data.Vector as V
import qualified Data.Text.IO as TIO

import Sugar

-- SugarCube is a refined type of Sugar.
-- This is a useful interface when a Json-like format is easier.
-- Differences:
-- * No notes
-- * No list wrap
-- * Maps are string-key value pairs
data SugarCube
  = SugarCube'Unit
  | SugarCube'Text Text
  | SugarCube'List [SugarCube]
  | SugarCube'Map (Map Text SugarCube)
  deriving (SugarCube -> SugarCube -> Bool
(SugarCube -> SugarCube -> Bool)
-> (SugarCube -> SugarCube -> Bool) -> Eq SugarCube
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: SugarCube -> SugarCube -> Bool
$c/= :: SugarCube -> SugarCube -> Bool
== :: SugarCube -> SugarCube -> Bool
$c== :: SugarCube -> SugarCube -> Bool
Eq, Int -> SugarCube -> ShowS
[SugarCube] -> ShowS
SugarCube -> String
(Int -> SugarCube -> ShowS)
-> (SugarCube -> String)
-> ([SugarCube] -> ShowS)
-> Show SugarCube
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [SugarCube] -> ShowS
$cshowList :: [SugarCube] -> ShowS
show :: SugarCube -> String
$cshow :: SugarCube -> String
showsPrec :: Int -> SugarCube -> ShowS
$cshowsPrec :: Int -> SugarCube -> ShowS
Show)

class ToSugarCube a where
  toSugarCube :: a -> SugarCube

sugarCubeMay :: Sugar -> Maybe SugarCube
sugarCubeMay :: Sugar -> Maybe SugarCube
sugarCubeMay (Sugar'Unit Note
_) = SugarCube -> Maybe SugarCube
forall a. a -> Maybe a
Just SugarCube
SugarCube'Unit
sugarCubeMay (Sugar'Text Text
t Note
_) = SugarCube -> Maybe SugarCube
forall a. a -> Maybe a
Just (SugarCube -> Maybe SugarCube) -> SugarCube -> Maybe SugarCube
forall a b. (a -> b) -> a -> b
$ Text -> SugarCube
SugarCube'Text Text
t
sugarCubeMay (Sugar'List [Sugar]
xs Wrap
_ Note
_) = do
  [SugarCube]
xs' <- (Sugar -> Maybe SugarCube) -> [Sugar] -> Maybe [SugarCube]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Sugar -> Maybe SugarCube
sugarCubeMay [Sugar]
xs
  SugarCube -> Maybe SugarCube
forall (m :: * -> *) a. Monad m => a -> m a
return (SugarCube -> Maybe SugarCube) -> SugarCube -> Maybe SugarCube
forall a b. (a -> b) -> a -> b
$ [SugarCube] -> SugarCube
SugarCube'List [SugarCube]
xs'
sugarCubeMay (Sugar'Map [(Sugar, Sugar)]
xs Note
_) = do
  [(Text, SugarCube)]
xs' <- ((Sugar, Sugar) -> Maybe (Text, SugarCube))
-> [(Sugar, Sugar)] -> Maybe [(Text, SugarCube)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (\(Sugar
k,Sugar
v) -> (,) (Text -> SugarCube -> (Text, SugarCube))
-> Maybe Text -> Maybe (SugarCube -> (Text, SugarCube))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Sugar -> Maybe Text
sugarTextMay Sugar
k Maybe (SugarCube -> (Text, SugarCube))
-> Maybe SugarCube -> Maybe (Text, SugarCube)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Sugar -> Maybe SugarCube
sugarCubeMay Sugar
v) [(Sugar, Sugar)]
xs
  SugarCube -> Maybe SugarCube
forall (m :: * -> *) a. Monad m => a -> m a
return (SugarCube -> Maybe SugarCube) -> SugarCube -> Maybe SugarCube
forall a b. (a -> b) -> a -> b
$ Map Text SugarCube -> SugarCube
SugarCube'Map ([(Text, SugarCube)] -> Map Text SugarCube
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(Text, SugarCube)]
xs')

  
writeJsonAsSugarBinary :: FilePath -> FilePath -> IO ()
writeJsonAsSugarBinary :: String -> String -> IO ()
writeJsonAsSugarBinary String
src String
des = do
  ByteString
bsl <- String -> IO ByteString
BL.readFile String
src
  let value' :: Note
value' = ByteString -> Note
forall a. FromJSON a => ByteString -> Maybe a
Json.decode' ByteString
bsl :: Maybe Sugar
  case Note
value' of
    Note
Nothing -> String -> IO ()
putStrLn String
"Can not decode"
    Just Sugar
sugar ->  String -> ByteString -> IO ()
BS.writeFile String
des (ByteString -> IO ()) -> ByteString -> IO ()
forall a b. (a -> b) -> a -> b
$ Sugar -> ByteString
forall a. Serialize a => a -> ByteString
Serialize.encode Sugar
sugar

writeJsonAsSugar :: FilePath -> FilePath -> IO ()
writeJsonAsSugar :: String -> String -> IO ()
writeJsonAsSugar String
src String
des = do
  ByteString
bsl <- String -> IO ByteString
BL.readFile String
src
  let value' :: Note
value' = ByteString -> Note
forall a. FromJSON a => ByteString -> Maybe a
Json.decode' ByteString
bsl :: Maybe Sugar
  case Note
value' of
    Note
Nothing -> String -> IO ()
putStrLn String
"Can not decode"
    Just Sugar
sugar ->  String -> Text -> IO ()
TIO.writeFile String
des (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ Sugar -> Text
prettyPrintSugar Sugar
sugar


instance ToSugar SugarCube where
  toSugar :: SugarCube -> Sugar
toSugar SugarCube
SugarCube'Unit = Note -> Sugar
Sugar'Unit Note
forall a. Maybe a
Nothing
  toSugar (SugarCube'Text Text
t) = Text -> Note -> Sugar
Sugar'Text Text
t Note
forall a. Maybe a
Nothing
  toSugar (SugarCube'List [SugarCube]
xs) = [Sugar] -> Wrap -> Note -> Sugar
Sugar'List ((SugarCube -> Sugar) -> [SugarCube] -> [Sugar]
forall a b. (a -> b) -> [a] -> [b]
map (Wrap -> SugarCube -> Sugar
toSugarWithWrap Wrap
Wrap'Paren) [SugarCube]
xs) Wrap
Wrap'Square Note
forall a. Maybe a
Nothing
    where
      -- Alternate nesting between Wrap types
      toSugarWithWrap :: Wrap -> SugarCube -> Sugar
toSugarWithWrap Wrap
w SugarCube
c = case SugarCube
c of
        SugarCube'List [SugarCube]
ys -> [Sugar] -> Wrap -> Note -> Sugar
Sugar'List ((SugarCube -> Sugar) -> [SugarCube] -> [Sugar]
forall a b. (a -> b) -> [a] -> [b]
map (Wrap -> SugarCube -> Sugar
toSugarWithWrap (case Wrap
w of Wrap
Wrap'Square -> Wrap
Wrap'Paren; Wrap
Wrap'Paren -> Wrap
Wrap'Square)) [SugarCube]
ys) Wrap
w Note
forall a. Maybe a
Nothing
        SugarCube
_ -> SugarCube -> Sugar
forall a. ToSugar a => a -> Sugar
toSugar SugarCube
c
  toSugar (SugarCube'Map Map Text SugarCube
m) = [(Sugar, Sugar)] -> Note -> Sugar
Sugar'Map (((Text, SugarCube) -> (Sugar, Sugar))
-> [(Text, SugarCube)] -> [(Sugar, Sugar)]
forall a b. (a -> b) -> [a] -> [b]
map (\(Text
k,SugarCube
v) -> (Text -> Sugar
forall a. ToSugar a => a -> Sugar
toSugar Text
k, SugarCube -> Sugar
forall a. ToSugar a => a -> Sugar
toSugar SugarCube
v)) ([(Text, SugarCube)] -> [(Sugar, Sugar)])
-> [(Text, SugarCube)] -> [(Sugar, Sugar)]
forall a b. (a -> b) -> a -> b
$ Map Text SugarCube -> [(Text, SugarCube)]
forall k a. Map k a -> [(k, a)]
Map.toList Map Text SugarCube
m) Note
forall a. Maybe a
Nothing

instance ToSugarCube Json.Value where
  toSugarCube :: Value -> SugarCube
toSugarCube Value
Json.Null = SugarCube
SugarCube'Unit
  toSugarCube (Json.Bool Bool
b) = Text -> SugarCube
SugarCube'Text (Bool -> Text
forall a. TextShow a => a -> Text
showt Bool
b)
  toSugarCube (Json.String Text
t) = Text -> SugarCube
SugarCube'Text Text
t
  toSugarCube (Json.Number Scientific
n) = Text -> SugarCube
SugarCube'Text (Scientific -> Text
showNumber Scientific
n)
    where
      showNumber :: Scientific -> Text
showNumber Scientific
s = (Double -> Text)
-> (Integer -> Text) -> Either Double Integer -> Text
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either Double -> Text
forall a. TextShow a => a -> Text
showt Integer -> Text
forall a. TextShow a => a -> Text
showt (Either Double Integer -> Text) -> Either Double Integer -> Text
forall a b. (a -> b) -> a -> b
$ (Scientific -> Either Double Integer
forall r i. (RealFloat r, Integral i) => Scientific -> Either r i
floatingOrInteger Scientific
s :: Either Double Integer)
  toSugarCube (Json.Array Array
a) = [SugarCube] -> SugarCube
SugarCube'List ([SugarCube] -> SugarCube) -> [SugarCube] -> SugarCube
forall a b. (a -> b) -> a -> b
$ (Value -> SugarCube) -> [Value] -> [SugarCube]
forall a b. (a -> b) -> [a] -> [b]
map Value -> SugarCube
forall a. ToSugarCube a => a -> SugarCube
toSugarCube (Array -> [Value]
forall a. Vector a -> [a]
V.toList Array
a)
  toSugarCube (Json.Object Object
o) = Map Text SugarCube -> SugarCube
SugarCube'Map (Map Text SugarCube -> SugarCube)
-> (Object -> Map Text SugarCube) -> Object -> SugarCube
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(Text, SugarCube)] -> Map Text SugarCube
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(Text, SugarCube)] -> Map Text SugarCube)
-> (Object -> [(Text, SugarCube)]) -> Object -> Map Text SugarCube
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Key, Value) -> (Text, SugarCube))
-> [(Key, Value)] -> [(Text, SugarCube)]
forall a b. (a -> b) -> [a] -> [b]
map (\(Key
k,Value
v) -> (Key -> Text
keyText Key
k, Value -> SugarCube
forall a. ToSugarCube a => a -> SugarCube
toSugarCube Value
v)) ([(Key, Value)] -> [(Text, SugarCube)])
-> (Object -> [(Key, Value)]) -> Object -> [(Text, SugarCube)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Object -> [(Key, Value)]
forall v. KeyMap v -> [(Key, v)]
KeyMap.toList (Object -> SugarCube) -> Object -> SugarCube
forall a b. (a -> b) -> a -> b
$ Object
o
    where
#if MIN_VERSION_aeson(2,0,0)
      keyText :: Key -> Text
keyText = Key -> Text
AesonKey.toText
#else
      keyText = id
#endif
  
instance Json.FromJSON SugarCube where
  parseJSON :: Value -> Parser SugarCube
parseJSON Value
v = SugarCube -> Parser SugarCube
forall (f :: * -> *) a. Applicative f => a -> f a
pure (SugarCube -> Parser SugarCube) -> SugarCube -> Parser SugarCube
forall a b. (a -> b) -> a -> b
$ Value -> SugarCube
forall a. ToSugarCube a => a -> SugarCube
toSugarCube Value
v
  
instance Json.FromJSON Sugar where
  parseJSON :: Value -> Parser Sugar
parseJSON Value
v = Sugar -> Parser Sugar
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Sugar -> Parser Sugar)
-> (Value -> Sugar) -> Value -> Parser Sugar
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SugarCube -> Sugar
forall a. ToSugar a => a -> Sugar
toSugar (SugarCube -> Sugar) -> (Value -> SugarCube) -> Value -> Sugar
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Value -> SugarCube
forall a. ToSugarCube a => a -> SugarCube
toSugarCube (Value -> Parser Sugar) -> Value -> Parser Sugar
forall a b. (a -> b) -> a -> b
$ Value
v