{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE PatternGuards #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ExtendedDefaultRules #-}
{-# LANGUAGE FlexibleContexts #-}
{-# OPTIONS_GHC -fno-warn-type-defaults #-}

-- | A JSON API which describes itself.

module Descriptive.JSON
  (-- * Consumers
   parse
  ,object
  ,key
  ,keyMaybe
  ,array
  ,string
  ,integer
  ,double
  ,bool
  ,null
  -- * Annotations
  ,label
  -- * Description
  ,Doc(..)
  )
  where

import           Descriptive
import           Descriptive.Internal

import           Control.Monad.State.Strict
import           Data.Scientific
import           Data.Function
import           Data.Aeson hiding (Value(Object,Null,Array),object)
import           Data.Aeson.Types (Value,parseMaybe)
import qualified Data.Aeson.Types as Aeson
import           Data.Bifunctor
import           Data.Data
import           Data.Monoid
import           Data.Text (Text)
import           Data.Vector ((!))
import           Data.Vector (Vector)
import qualified Data.Vector as V
import           Prelude hiding (null)

-- | Description of parseable things.
data Doc a
  = Integer !Text
  | Double !Text
  | Text !Text
  | Boolean !Text
  | Null !Text
  | Object !Text
  | Key !Text
  | Array !Text
  | Label !a
  deriving (Eq,Show,Typeable,Data)

-- | Consume an object.
object :: Monad m
       => Text -- ^ Description of what the object is.
       -> Consumer Object (Doc d) m a -- ^ An object consumer.
       -> Consumer Value (Doc d) m a
object desc =
  wrap (\d ->
          do s <- get
             runSubStateT (const mempty)
                          (const s)
                          (liftM (Wrap doc) d))
       (\_ p ->
          do v <- get
             case fromJSON v of
               Error{} ->
                 return (Continued (Unit doc))
               Success (o :: Object) ->
                 do s <- get
                    runSubStateT
                      (const o)
                      (const s)
                      (do r <- p
                          case r of
                            Failed e ->
                              return (Continued (Wrap doc e))
                            Continued e ->
                              return (Continued (Wrap doc e))
                            Succeeded a ->
                              return (Succeeded a)))
  where doc = Object desc

-- | Consume from object at the given key.
key :: Monad m
    => Text -- ^ The key to lookup.
    -> Consumer Value (Doc d) m a -- ^ A value consumer of the object at the key.
    -> Consumer Object (Doc d) m a
key k =
  wrap (\d ->
          do s <- get
             runSubStateT toJSON
                          (const s)
                          (liftM (Wrap doc) d))
       (\_ p ->
          do s <- get
             case parseMaybe (const (s .: k))
                             () of
               Nothing ->
                 return (Continued (Unit doc))
               Just (v :: Value) ->
                 do r <-
                      runSubStateT (const v)
                                   (const s)
                                   p
                    return (bimap (Wrap doc) id r))
  where doc = Key k

-- | Optionally consume from object at the given key, only if it
-- exists.
keyMaybe :: Monad m
         => Text -- ^ The key to lookup.
         -> Consumer Value (Doc d) m a -- ^ A value consumer of the object at the key.
         -> Consumer Object (Doc d) m (Maybe a)
keyMaybe k =
  wrap (\d ->
          do s <- get
             runSubStateT toJSON
                          (const s)
                          (liftM (Wrap doc) d))
       (\_ p ->
          do s <- get
             case parseMaybe (const (s .: k))
                             () of
               Nothing ->
                 return (Succeeded Nothing)
               Just (v :: Value) ->
                 do r <-
                      runSubStateT (const v)
                                   (const s)
                                   p
                    return (bimap (Wrap doc) Just r))
  where doc = Key k

-- | Consume an array.
array :: Monad m
      => Text -- ^ Description of this array.
      -> Consumer Value (Doc d) m a -- ^ Consumer for each element in the array.
      -> Consumer Value (Doc d) m (Vector a)
array desc =
  wrap (\d -> liftM (Wrap doc) d)
       (\_ p ->
          do s <- get
             case fromJSON s of
               Error{} ->
                 return (Continued (Unit doc))
               Success (o :: Vector Value) ->
                 fix (\loop i acc ->
                        if i < V.length o
                           then do r <-
                                     runSubStateT (const (o ! i))
                                                  (const s)
                                                  p
                                   case r of
                                     Failed e ->
                                       return (Continued (Wrap doc e))
                                     Continued e ->
                                       return (Continued (Wrap doc e))
                                     Succeeded a ->
                                       loop (i + 1)
                                            (a : acc)
                           else return (Succeeded (V.fromList (reverse acc))))
                     0
                     [])
  where doc = Array desc

-- | Consume a string.
string :: Monad m
       => Text -- ^ Description of what the string is for.
       -> Consumer Value (Doc d) m Text
string doc =
  consumer (return d)
           (do s <- get
               case fromJSON s of
                 Error{} -> return (Continued d)
                 Success a ->
                   return (Succeeded a))
  where d = Unit (Text doc)

-- | Consume an integer.
integer :: Monad m
        => Text -- ^ Description of what the integer is for.
        -> Consumer Value (Doc d) m Integer
integer doc =
  consumer (return d)
           (do s <- get
               case s of
                 Number a
                   | Right i <- floatingOrInteger a ->
                     return (Succeeded i)
                 _ -> return (Continued d))
  where d = Unit (Integer doc)

-- | Consume an double.
double :: Monad m
       => Text -- ^ Description of what the double is for.
       -> Consumer Value (Doc d) m Double
double doc =
  consumer (return d)
           (do s <- get
               case s of
                 Number a ->
                   return (Succeeded (toRealFloat a))
                 _ -> return (Continued d))
  where d = Unit (Double doc)

-- | Parse a boolean.
bool :: Monad m
     => Text -- ^ Description of what the bool is for.
     -> Consumer Value (Doc d) m Bool
bool doc =
  consumer (return d)
           (do s <- get
               case fromJSON s of
                 Error{} -> return (Continued d)
                 Success a ->
                   return (Succeeded a))
  where d = Unit (Boolean doc)

-- | Expect null.
null :: Monad m
     => Text -- ^ What the null is for.
     -> Consumer Value (Doc d) m ()
null doc =
  consumer (return d)
           (do s <- get
               case fromJSON s of
                 Success Aeson.Null ->
                   return (Succeeded ())
                 _ -> return (Continued d))
  where d = Unit (Null doc)

-- | Wrap a consumer with a label e.g. a type tag.
label :: Monad m
      => d                      -- ^ Some label.
      -> Consumer s (Doc d) m a -- ^ A value consumer.
      -> Consumer s (Doc d) m a
label desc =
  wrap (liftM (Wrap doc))
       (\_ p ->
          do r <- p
             case r of
               Failed e ->
                 return (Failed (Wrap doc e))
               Continued e ->
                 return (Continued (Wrap doc e))
               k -> return k)
  where doc = Label desc

-- | Parse from a consumer.
parse :: Monad m
      => d                           -- ^ Description of what it expects.
      -> (a -> StateT s m (Maybe b)) -- ^ Attempt to parse the value.
      -> Consumer s d m a            -- ^ Consumer to add validation to.
      -> Consumer s d m b            -- ^ A new validating consumer.
parse d' check =
  wrap (liftM wrapper)
       (\d p ->
          do s <- get
             r <- p
             case r of
               (Failed e) -> return (Failed e)
               (Continued e) ->
                 return (Continued e)
               (Succeeded a) ->
                 do r' <- check a
                    case r' of
                      Nothing ->
                        do doc <- withStateT (const s) d
                           return (Continued (wrapper doc))
                      Just a' -> return (Succeeded a'))
  where wrapper = Wrap d'