module Data.JsonSchema.Draft4.Schema where

import qualified Data.HashMap.Strict          as H
import           Data.List.NonEmpty           (NonEmpty)
import           Data.Maybe                   (fromJust, isJust)
import           Data.Scientific

import qualified Data.Validator.Draft4.Any    as AN
import qualified Data.Validator.Draft4.Array  as AR
import qualified Data.Validator.Draft4.Object as OB
import           Data.Validator.Utils
import           Import

data Schema = Schema
  { _schemaVersion              :: Maybe Text
  , _schemaId                   :: Maybe Text
  , _schemaRef                  :: Maybe Text
  , _schemaDefinitions          :: Maybe (HashMap Text Schema)
  -- ^ A standardized location for embedding schemas
  -- to be referenced from elsewhere in the document.
  , _schemaOther                :: HashMap Text Value
  -- ^ Since the JSON document this Schema was built from could
  -- contain schemas anywhere (not just in "definitions" or any
  -- of the other official keys) we save any leftover key/value
  -- pairs not covered by them here.

  , _schemaMultipleOf           :: Maybe Scientific
  , _schemaMaximum              :: Maybe Scientific
  , _schemaExclusiveMaximum     :: Maybe Bool
  , _schemaMinimum              :: Maybe Scientific
  , _schemaExclusiveMinimum     :: Maybe Bool

  , _schemaMaxLength            :: Maybe Int
  , _schemaMinLength            :: Maybe Int
  , _schemaPattern              :: Maybe Text

  , _schemaMaxItems             :: Maybe Int
  , _schemaMinItems             :: Maybe Int
  , _schemaUniqueItems          :: Maybe Bool
  , _schemaItems                :: Maybe (AR.Items Schema)
  -- Note that '_schemaAdditionalItems' is left out of 'runValidate'
  -- because its functionality is handled by '_schemaItems'. It always
  -- validates data unless 'Items' is present.
  , _schemaAdditionalItems      :: Maybe (AR.AdditionalItems Schema)

  , _schemaMaxProperties        :: Maybe Int
  , _schemaMinProperties        :: Maybe Int
  , _schemaRequired             :: Maybe OB.Required
  , _schemaDependencies         :: Maybe (HashMap Text (OB.Dependency Schema))
  , _schemaProperties           :: Maybe (HashMap Text Schema)
  , _schemaPatternProperties    :: Maybe (HashMap Text Schema)
  , _schemaAdditionalProperties :: Maybe (OB.AdditionalProperties Schema)

  , _schemaEnum                 :: Maybe AN.EnumVal
  , _schemaType                 :: Maybe AN.TypeVal
  , _schemaAllOf                :: Maybe (NonEmpty Schema)
  , _schemaAnyOf                :: Maybe (NonEmpty Schema)
  , _schemaOneOf                :: Maybe (NonEmpty Schema)
  , _schemaNot                  :: Maybe Schema
  } deriving (Eq, Show)

emptySchema :: Schema
emptySchema = Schema
  { _schemaVersion              = Nothing
  , _schemaId                   = Nothing
  , _schemaRef                  = Nothing
  , _schemaDefinitions          = Nothing
  , _schemaOther                = mempty

  , _schemaMultipleOf           = Nothing
  , _schemaMaximum              = Nothing
  , _schemaExclusiveMaximum     = Nothing
  , _schemaMinimum              = Nothing
  , _schemaExclusiveMinimum     = Nothing

  , _schemaMaxLength            = Nothing
  , _schemaMinLength            = Nothing
  , _schemaPattern              = Nothing

  , _schemaMaxItems             = Nothing
  , _schemaMinItems             = Nothing
  , _schemaUniqueItems          = Nothing
  , _schemaItems                = Nothing
  , _schemaAdditionalItems      = Nothing

  , _schemaMaxProperties        = Nothing
  , _schemaMinProperties        = Nothing
  , _schemaRequired             = Nothing
  , _schemaDependencies         = Nothing
  , _schemaProperties           = Nothing
  , _schemaPatternProperties    = Nothing
  , _schemaAdditionalProperties = Nothing

  , _schemaEnum                 = Nothing
  , _schemaType                 = Nothing
  , _schemaAllOf                = Nothing
  , _schemaAnyOf                = Nothing
  , _schemaOneOf                = Nothing
  , _schemaNot                  = Nothing
  }

instance FromJSON Schema where
  parseJSON = withObject "Schema" $ \o -> do
    a  <- o .:? "$schema"
    b  <- o .:? "id"
    c  <- o .:? "$ref"
    d  <- o .:? "definitions"
    e  <- parseJSON (Object (H.difference o internalSchemaHashMap))

    f  <- o .:? "multipleOf"
    g  <- o .:? "maximum"
    h  <- o .:? "exclusiveMaximum"
    i  <- o .:? "minimum"
    j  <- o .:? "exclusiveMinimum"

    k  <- o .:? "maxLength"
    l  <- o .:? "minLength"
    m  <- o .:? "pattern"

    n  <- o .:? "maxItems"
    o' <- o .:? "minItems"
    p  <- o .:? "uniqueItems"
    q  <- o .:? "items"
    r  <- o .:? "additionalItems"

    s  <- o .:? "maxProperties"
    t  <- o .:? "minProperties"
    u  <- o .:? "required"
    v  <- o .:? "dependencies"
    w  <- o .:? "properties"
    x  <- o .:? "patternProperties"
    y  <- o .:? "additionalProperties"

    z  <- o .:? "enum"
    a2 <- o .:? "type"
    b2 <- fmap _unNonEmpty' <$> o .:? "allOf"
    c2 <- fmap _unNonEmpty' <$> o .:? "anyOf"
    d2 <- fmap _unNonEmpty' <$> o .:? "oneOf"
    e2 <- o .:? "not"
    pure Schema
      { _schemaVersion              = a
      , _schemaId                   = b
      , _schemaRef                  = c
      , _schemaDefinitions          = d
      , _schemaOther                = e

      , _schemaMultipleOf           = f
      , _schemaMaximum              = g
      , _schemaExclusiveMaximum     = h
      , _schemaMinimum              = i
      , _schemaExclusiveMinimum     = j

      , _schemaMaxLength            = k
      , _schemaMinLength            = l
      , _schemaPattern              = m

      , _schemaMaxItems             = n
      , _schemaMinItems             = o'
      , _schemaUniqueItems          = p
      , _schemaItems                = q
      , _schemaAdditionalItems      = r

      , _schemaMaxProperties        = s
      , _schemaMinProperties        = t
      , _schemaRequired             = u
      , _schemaDependencies         = v
      , _schemaProperties           = w
      , _schemaPatternProperties    = x
      , _schemaAdditionalProperties = y

      , _schemaEnum                 = z
      , _schemaType                 = a2
      , _schemaAllOf                = b2
      , _schemaAnyOf                = c2
      , _schemaOneOf                = d2
      , _schemaNot                  = e2
      }

instance ToJSON Schema where
  -- | The way we resolve JSON Pointers to embedded schemas is by
  -- serializing the containing schema to a value and then resolving the
  -- pointer against it. This means that FromJSON and ToJSON must be
  -- isomorphic.
  --
  -- This influences the design choices in the library. E.g. right now
  -- there are two false values for "exclusiveMaximum" -- Nothing and
  -- Just False. We could have condensed them down by using () instead
  -- of Bool for "exclusiveMaximum". This would have made writing schemas
  -- in haskell easier, but we could no longer round trip through/from
  -- JSON without losing information.
  toJSON s = Object $ H.union (mapMaybe ($ s) internalSchemaHashMap) (toJSON <$> _schemaOther s)
    where
      -- 'mapMaybe' is provided by unordered-containers after unordered-container-2.6.0.0,
      -- but until that is a little older (and has time to get into Stackage etc.)
      -- we use our own implementation.
      mapMaybe :: (v1 -> Maybe v2) -> HashMap k v1 -> HashMap k v2
      mapMaybe f = fmap fromJust . H.filter isJust . fmap f

-- | Internal. Separate from ToJSON because it's also used
-- by FromJSON to determine what keys aren't official schema
-- keys and therefor should be included in _schemaOther.
internalSchemaHashMap :: HashMap Text (Schema -> Maybe Value)
internalSchemaHashMap = H.fromList
  [ ("$schema"             , f _schemaVersion)
  , ("id"                  , f _schemaId)
  , ("$ref"                , f _schemaRef)
  , ("definitions"         , f _schemaDefinitions)

  , ("multipleOf"          , f _schemaMultipleOf)
  , ("maximum"             , f _schemaMaximum)
  , ("exclusiveMaximum"    , f _schemaExclusiveMaximum)
  , ("minimum"             , f _schemaMinimum)
  , ("exclusiveMinimum"    , f _schemaExclusiveMinimum)

  , ("maxLength"           , f _schemaMaxLength)
  , ("minLength"           , f _schemaMinLength)
  , ("pattern"             , f _schemaPattern)

  , ("maxItems"            , f _schemaMaxItems)
  , ("minItems"            , f _schemaMinItems)
  , ("uniqueItems"         , f _schemaUniqueItems)
  , ("items"               , f _schemaItems)
  , ("additionalItems"     , f _schemaAdditionalItems)

  , ("maxProperties"       , f _schemaMaxProperties)
  , ("minProperties"       , f _schemaMinProperties)
  , ("required"            , f _schemaRequired)
  , ("dependencies"        , f _schemaDependencies)
  , ("properties"          , f _schemaProperties)
  , ("patternProperties"   , f _schemaPatternProperties)
  , ("additionalProperties", f _schemaAdditionalProperties)

  , ("enum"                , f _schemaEnum)
  , ("type"                , f _schemaType)
  , ("allOf"               , f (fmap NonEmpty' . _schemaAllOf))
  , ("anyOf"               , f (fmap NonEmpty' . _schemaAnyOf))
  , ("oneOf"               , f (fmap NonEmpty' . _schemaOneOf))
  , ("not"                 , f _schemaNot)
  ]
  where
    f :: ToJSON a => (Schema -> Maybe a) -> Schema -> Maybe Value
    f = (fmap.fmap) toJSON

instance Arbitrary Schema where
  arbitrary = sized f
    where
      maybeGen :: Gen a -> Gen (Maybe a)
      maybeGen a = oneof [pure Nothing, Just <$> a]

      maybeRecurse :: Int -> Gen a -> Gen (Maybe a)
      maybeRecurse n a
        | n < 1     = pure Nothing
        | otherwise = maybeGen $ resize (n `div` 10) a

      f :: Int -> Gen Schema
      f n = do
        a  <- maybeGen arbitraryText
        b  <- maybeGen arbitraryText
        c  <- maybeGen arbitraryText
           -- NOTE: The next two fields are empty to generate cleaner schemas,
           -- but note that this means we don't test e.g. the invertability
           -- of these fields.
        d  <- pure Nothing -- _schemaDefinitions
        e  <- pure mempty -- _otherPairs

        f' <- maybeGen arbitraryPositiveScientific
        g  <- maybeGen arbitraryScientific
        h  <- arbitrary
        i  <- maybeGen arbitraryScientific
        j  <- arbitrary

        k  <- maybeGen (getPositive <$> arbitrary)
        l  <- maybeGen (getPositive <$> arbitrary)
        m  <- maybeGen arbitraryText

        n' <- maybeGen (getPositive <$> arbitrary)
        o  <- maybeGen (getPositive <$> arbitrary)
        p  <- arbitrary
        q  <- maybeRecurse n arbitrary
        r  <- maybeRecurse n arbitrary

        s  <- maybeGen (getPositive <$> arbitrary)
        t  <- maybeGen (getPositive <$> arbitrary)
        u  <- arbitrary
        v  <- maybeRecurse n arbitraryHashMap
        w  <- maybeRecurse n arbitraryHashMap
        x  <- maybeRecurse n arbitraryHashMap
        y  <- maybeRecurse n arbitrary

        z  <- arbitrary
        a2 <- arbitrary
        b2 <- maybeRecurse n (_unNonEmpty' <$> arbitrary)
        c2 <- maybeRecurse n (_unNonEmpty' <$> arbitrary)
        d2 <- maybeRecurse n (_unNonEmpty' <$> arbitrary)
        e2 <- maybeRecurse n arbitrary
        pure Schema
          { _schemaVersion              = a
          , _schemaId                   = b
          , _schemaRef                  = c
          , _schemaDefinitions          = d
          , _schemaOther                = e

          , _schemaMultipleOf           = f'
          , _schemaMaximum              = g
          , _schemaExclusiveMaximum     = h
          , _schemaMinimum              = i
          , _schemaExclusiveMinimum     = j

          , _schemaMaxLength            = k
          , _schemaMinLength            = l
          , _schemaPattern              = m

          , _schemaMaxItems             = n'
          , _schemaMinItems             = o
          , _schemaUniqueItems          = p
          , _schemaItems                = q
          , _schemaAdditionalItems      = r

          , _schemaMaxProperties        = s
          , _schemaMinProperties        = t
          , _schemaRequired             = u
          , _schemaDependencies         = v
          , _schemaProperties           = w
          , _schemaPatternProperties    = x
          , _schemaAdditionalProperties = y

          , _schemaEnum                 = z
          , _schemaType                 = a2
          , _schemaAllOf                = b2
          , _schemaAnyOf                = c2
          , _schemaOneOf                = d2
          , _schemaNot                  = e2
          }