module JSONSchema.Draft4.Schema where

import           Import                      hiding (mapMaybe)

import qualified Data.HashMap.Strict         as HM
import           Data.List.NonEmpty          (NonEmpty)
import           Data.Maybe                  (fromJust, isJust)
import           Data.Scientific
import qualified Data.Set                    as Set
import qualified Data.Text                   as T

import qualified JSONSchema.Validator.Draft4 as D4
import           JSONSchema.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.
    --
    -- TODO: This field is the source of most of the complication in this
    -- module and needs to be removed. It should be doable, though it will
    -- involve some modification to the fetching code.

    , _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 (D4.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 (D4.AdditionalItems Schema)

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

    , _schemaEnum                 :: Maybe (NonEmpty Value)
    , _schemaType                 :: Maybe D4.TypeValidator
    , _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 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  <- maybeGen (Set.map T.pack <$> arbitrary)
            v  <- maybeRecurse n arbitraryHashMap
            w  <- maybeRecurse n arbitraryHashMap
            x  <- maybeRecurse n arbitraryHashMap
            y  <- maybeRecurse n arbitrary

            z  <- maybeRecurse n ( fmap _unArbitraryValue . _unNonEmpty'
                               <$> 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
                }