{-# LANGUAGE ScopedTypeVariables #-}

module Data.JsonSchema.Draft4.Objects
  ( module Data.JsonSchema.Draft4.Objects
  , module Data.JsonSchema.Draft4.Objects.Properties
  ) where

import           Control.Monad
import           Data.Aeson
import           Data.Hashable
import qualified Data.HashMap.Strict     as H
import qualified Data.Vector             as V

import           Data.JsonSchema.Core
import           Data.JsonSchema.Draft4.Objects.Properties
import           Data.JsonSchema.Helpers
import           Import

data DependencyFailure err = SchemaDependency err | PropertyDependency

maxProperties :: ValidatorConstructor err [FailureInfo]
maxProperties _ _ _ val = do
  n <- fromJSONInt val
  greaterThanZero n
  Just $ \x ->
    case x of
      Object o ->
        if H.size o > n
          then pure (FailureInfo val x)
          else mempty
      _ -> mempty

minProperties :: ValidatorConstructor err [FailureInfo]
minProperties _ _ _ val = do
  n <- fromJSONInt val
  greaterThanZero n
  Just $ \x ->
    case x of
      Object o ->
        if H.size o < n
          then pure (FailureInfo val x)
          else mempty
      _ -> mempty

required :: ValidatorConstructor err [FailureInfo]
required _ _ _ val@(Array vs) = do
  when (V.length vs == 0) Nothing
  ts <- traverse toTxt vs
  let a = vectorToMapSet ts
  when (H.size a /= V.length ts) Nothing
  Just $ \x ->
    case x of
      Object o ->
        if H.size (H.difference a o) > 0
          then pure (FailureInfo val x)
          else mempty
      _ -> mempty
  where
    vectorToMapSet :: (Eq a, Hashable a) => Vector a -> HashMap a Bool
    vectorToMapSet vec = H.fromList . V.toList $ (\x -> (x, True)) <$> vec -- TODO: use a fold.
required _ _ _ _ = Nothing

-- http://json-schema.org/latest/json-schema-validation.html#anchor70
--
-- > This keyword's value MUST be an object.
-- > Each value of this object MUST be either an object or an array.
-- >
-- > If the value is an object, it MUST be a valid JSON Schema.
-- > This is called a schema dependency.
-- >
-- > If the value is an array, it MUST have at least one element.
-- > Each element MUST be a string, and elements in the array MUST be unique.
-- > This is called a property dependency.
dependencies :: ValidatorConstructor err [ValidationFailure (DependencyFailure err)]
dependencies spec g s val@(Object o) = do
  let vs = H.toList o
      schemaDeps = vs >>= toSchemaDep spec g
      propDeps = vs >>= toPropDep
  when (length schemaDeps + length propDeps /= length vs) Nothing
  Just $ \x ->
    case x of
      Object y ->
        let schemaFailures = join $ valSD y <$> schemaDeps
            propertyFailures = join $ valPD y <$> propDeps
        in schemaFailures <> propertyFailures
      _ -> mempty
  where
    toSchemaDep :: Spec a -> Graph -> (Text, Value) -> [(Text, Schema a)]
    toSchemaDep spc gr (t, Object ob) = pure (t, compile spc gr $ RawSchema (_rsURI s) ob)
    toSchemaDep _ _ _ = mempty

    toPropDep :: (Text, Value) -> [(Text, Vector Text)]
    toPropDep (t, Array a) =
      if V.length a <= 0
        then mempty
        else case traverse toTxt a of
          Nothing -> mempty
          Just ts ->
            if allUnique ts
              then pure (t, ts)
              else mempty
    toPropDep _ = mempty

    valSD :: HashMap Text Value -> (Text, Schema err) -> [ValidationFailure (DependencyFailure err)]
    valSD d (k, subSchema) =
      case H.lookup k d of
        Nothing -> mempty
        Just _  -> modifyFailureName SchemaDependency <$> validate subSchema (Object d)

    valPD :: HashMap Text Value -> (Text, Vector Text) -> [ValidationFailure (DependencyFailure err)]
    valPD d (k, ks) =
      case H.lookup k d of
        Nothing -> mempty
        Just _  ->
          case traverse (flip H.lookup d) ks of
            Nothing -> pure $ ValidationFailure PropertyDependency (FailureInfo val (Object d))
            Just _  -> mempty
dependencies _ _ _ _ = Nothing