JArray.hs

{-# LANGUAGE DeriveFoldable        #-}
{-# LANGUAGE DeriveFunctor         #-}
{-# LANGUAGE DeriveTraversable     #-}
{-# LANGUAGE FlexibleInstances     #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NoImplicitPrelude     #-}
{-# LANGUAGE RankNTypes            #-}
{-# LANGUAGE TypeFamilies          #-}
-- |
--
-- JSON Array representation and functions.
--
module Waargonaut.Types.JArray
  (
    -- * Types
    JArray (..)

    -- * Parser
  , parseJArray
  ) where

import           Prelude                   (Eq, Show, Int)

import           Control.Category          ((.))
import           Control.Error.Util        (note)
import           Control.Lens              (AsEmpty (..), Cons (..), Rewrapped, Ixed (..), Index, IxValue,
                                            Wrapped (..), cons, iso,
                                            nearly, over, prism, to, ( # ),
                                            (^.), (^?), _2, _Wrapped)
import           Control.Lens.Extras       (is)
import           Control.Monad             (Monad)

import           Data.Bifoldable           (Bifoldable (bifoldMap))
import           Data.Bifunctor            (Bifunctor (bimap))
import           Data.Bitraversable        (Bitraversable (bitraverse))
import           Data.Foldable             (Foldable)
import           Data.Function             (($))
import           Data.Functor              (Functor, (<$>))
import           Data.Monoid               (Monoid (..), mempty)
import           Data.Semigroup            (Semigroup (..))
import           Data.Traversable          (Traversable)

import           Text.Parser.Char          (CharParsing, char)

import           Waargonaut.Types.CommaSep (CommaSeparated,
                                            parseCommaSeparated)

-- $setup
-- >>> :set -XOverloadedStrings
-- >>> import Utils
-- >>> import Waargonaut.Types.Json
-- >>> import Waargonaut.Types.Whitespace
-- >>> import Control.Monad (return)
-- >>> import Data.Either (Either (..), isLeft)
-- >>> import Waargonaut.Decode.Error (DecodeError)
----

-- | Conveniently, a JSON array is a 'CommaSeparated' list with an optional
-- trailing comma, some instances and other functions need to work differently so
-- we wrap it up in a newtype.
newtype JArray ws a =
  JArray (CommaSeparated ws a)
  deriving (Eq, Show, Functor, Foldable, Traversable)

instance JArray ws a ~ t => Rewrapped (JArray ws a) t
instance Wrapped (JArray ws a) where
  type Unwrapped (JArray ws a) = CommaSeparated ws a
  _Wrapped' = iso (\(JArray x) -> x) JArray

instance Monoid ws => Cons (JArray ws a) (JArray ws a) a a where
  _Cons = prism
    (\(a,j) -> over _Wrapped (cons a) j)
    (\j -> note j $ over _2 (_Wrapped #) <$> j ^? _Wrapped . _Cons)
  {-# INLINE _Cons #-}

instance (Semigroup ws, Monoid ws) => AsEmpty (JArray ws a) where
  _Empty = nearly (JArray mempty) (^. _Wrapped . to (is _Empty))
  {-# INLINE _Empty #-}

instance (Monoid ws, Semigroup ws) => Semigroup (JArray ws a) where
  (JArray a) <> (JArray b) = JArray (a <> b)

instance (Semigroup ws, Monoid ws) => Monoid (JArray ws a) where
  mempty = JArray mempty
  mappend = (<>)

type instance IxValue (JArray ws a) = a
type instance Index (JArray ws a)   = Int

instance Ixed (JArray ws a) where
  ix i f (JArray cs) = JArray <$> ix i f cs

instance Bifunctor JArray where
  bimap f g (JArray cs) = JArray (bimap f g cs)

instance Bifoldable JArray where
  bifoldMap f g (JArray cs) = bifoldMap f g cs

instance Bitraversable JArray where
  bitraverse f g (JArray cs) = JArray <$> bitraverse f g cs

-- | Parse a single JSON array
--
-- >>> testparse (parseJArray parseWhitespace parseWaargonaut) "[null ]"
-- Right (JArray (CommaSeparated (WS []) (Just (Elems {_elemsElems = [], _elemsLast = Elem {_elemVal = Json (JNull (WS [Space])), _elemTrailing = Nothing}}))))
--
-- >>> testparse (parseJArray parseWhitespace parseWaargonaut) "[null,]"
-- Right (JArray (CommaSeparated (WS []) (Just (Elems {_elemsElems = [], _elemsLast = Elem {_elemVal = Json (JNull (WS [])), _elemTrailing = Just (Comma,WS [])}}))))
--
parseJArray
  :: ( Monad f
     , CharParsing f
     )
  => f ws
  -> f a
  -> f (JArray ws a)
parseJArray ws a = JArray <$>
  parseCommaSeparated (char '[') (char ']') ws a