module Data.JsonSchema.Draft4.Schema where

import           Import
import           Prelude

import qualified Data.HashMap.Strict          as HM
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

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 (HM.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 $ HM.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 . HM.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 = HM.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
                }