{-# LANGUAGE ScopedTypeVariables #-}

module Data.JsonSchema.Draft4.Objects.Properties where

import           Control.Monad
import           Data.Aeson
import qualified Data.HashMap.Strict     as H
import           Data.Maybe
import qualified Data.Text               as T
import           Text.RegexPR

import           Data.JsonSchema.Core
import           Data.JsonSchema.Helpers
import           Import

data PropertiesFailure err
  = Properties err
  | PropPattern err
  | PropAdditional (AdditionalPropertiesFailure err)

data PatternPropertiesFailure err
  = PatternProperties err
  | PatternAdditional (AdditionalPropertiesFailure err)

data AdditionalPropertiesFailure err
  = AdditionalPropertiesBool
  | AdditionalPropertiesObject err

-- | In order of what's tried: properties, patternProperties, additionalProperties
properties :: forall err. ValidatorConstructor err [ValidationFailure (PropertiesFailure err)]
properties spec g s val = do
  let mProps   = propertiesUnmatched val
      mPatProp = patternUnmatched spec g s =<< H.lookup "patternProperties" (_rsObject s)
      mAddProp = runAdditionalProperties spec g s =<< H.lookup "additionalProperties" (_rsObject s)
  when (isNothing mProps && isNothing mPatProp && isNothing mAddProp) Nothing
  Just $ \x ->
    case x of
      Object y ->
        let (propFailures, remaining) = runMaybeVal' mProps (Object y)
            patternFailures           = fst $ runMaybeVal' mPatProp (Object y)
            remaining'                = snd $ runMaybeVal' mPatProp remaining
            additionalFailures        = runMaybeVal mAddProp remaining'
        in fmap (modifyFailureName Properties) propFailures
             <> fmap (modifyFailureName PropPattern) patternFailures
             <> fmap (modifyFailureName PropAdditional) additionalFailures
      _ -> mempty
  where
    propertiesUnmatched :: Value -> Maybe (Value -> ([ValidationFailure err], Value))
    propertiesUnmatched (Object o) = do
      os <- traverse toObj o
      let matchedSchemas = compile spec g . RawSchema (_rsURI s) <$> os
      Just (\x ->
        case x of
          Object y ->
            let rawFailures = H.intersectionWith validate matchedSchemas y
                failures = join (H.elems rawFailures)
                leftovers = Object (H.difference y matchedSchemas)
            in (failures, leftovers)
          z -> (mempty, z))
    propertiesUnmatched _ = Nothing

patternProperties :: ValidatorConstructor err [ValidationFailure (PatternPropertiesFailure err)]
patternProperties spec g s val = do
  when (H.member "properties" (_rsObject s)) Nothing
  let mPatternProps = patternUnmatched spec g s val
  -- TODO: checking additionalProperties as well doesn't help with tests.
  -- Make sure we're doing the correct thing, then get tests for this
  -- merged into the test suite.
  let mAdditionalProps = runAdditionalProperties spec g s =<< H.lookup "additionalProperties" (_rsObject s)
  when (isNothing mPatternProps && isNothing mAdditionalProps) Nothing
  Just $ \x ->
    case x of
      Object y ->
        let (ppFailures, remaining') = runMaybeVal' mPatternProps (Object y)
            addFailures              = runMaybeVal mAdditionalProps remaining'
        in fmap (modifyFailureName PatternProperties) ppFailures <> fmap (modifyFailureName PatternAdditional) addFailures
      _ -> mempty

patternUnmatched
  :: Spec err
  -> Graph
  -> RawSchema
  -> Value
  -> Maybe (Value -> ([ValidationFailure err], Value))
patternUnmatched spec g s (Object val) = do
  os <- traverse toObj val
  let subSchemas = compile spec g . RawSchema (_rsURI s) <$> os
  Just (\x ->
    case x of
      Object y -> let ms = H.foldlWithKey' (matches subSchemas) mempty y
                  in (H.foldl' runVals mempty ms, Object (leftovers ms))
      _        -> (mempty, x))
  where
    matches
      :: HashMap Text (Schema a)
      -> HashMap Text (Value, [Schema a])
      -> Text
      -> Value
      -> HashMap Text (Value, [Schema a])
    matches subSchemas acc k v = H.insert k (v, H.foldlWithKey' (match k) mempty subSchemas) acc

    match
      :: Text
      -> [Schema a]
      -> Text
      -> Schema a
      -> [Schema a]
    match k acc r subSchema =
      case matchRegexPR (T.unpack r) (T.unpack k) of
        Nothing -> acc
        Just _  -> pure subSchema <> acc

    runVals
      :: [ValidationFailure err]
      -> (Value, [Schema err])
      -> [ValidationFailure err]
    runVals acc (v,subSchema) = (subSchema >>= flip validate v) <> acc

    leftovers :: HashMap Text (Value, [Schema a]) -> HashMap Text Value
    leftovers possiblyMatched = fst <$> H.filter (null . snd) possiblyMatched
patternUnmatched _ _ _ _ = Nothing

additionalProperties :: ValidatorConstructor err [ValidationFailure (AdditionalPropertiesFailure err)]
additionalProperties spec g s val = do
  when (H.member "properties" (_rsObject s)) Nothing
  when (H.member "patternProperties" (_rsObject s)) Nothing
  runAdditionalProperties spec g s val

-- | An additionalProperties validator than never disables itself.
--
-- Not meant to be used standalone, but useful inside of the properties
-- and patternProperties validators.
runAdditionalProperties :: ValidatorConstructor err [ValidationFailure (AdditionalPropertiesFailure err)]
runAdditionalProperties _ _ _ val@(Bool v) =
  Just $ \x ->
    case x of
      Object y ->
        if not v && H.size y > 0
          then pure $ ValidationFailure AdditionalPropertiesBool (FailureInfo val x)
          else mempty
      _ -> mempty
runAdditionalProperties spec g s (Object o) =
  let sub = compile spec g (RawSchema (_rsURI s) o)
  in Just $ \x ->
    case x of
      Object y -> H.elems y >>= fmap (modifyFailureName AdditionalPropertiesObject) . validate sub
      _        -> mempty
runAdditionalProperties _ _ _ _ = Nothing