------------------------------------------------------------------------------
-- | Contains definitions for generating 'MediaType's.
module Network.HTTP.Media.MediaType.Gen
    (
    -- * Generating MediaTypes
      anything
    , genMediaType
    , genSubStar
    , genMaybeSubStar
    , subStarOf
    , genConcreteMediaType
    , genWithoutParams
    , genWithParams
    , stripParams
    , genDiffMediaTypesWith
    , genDiffMediaTypeWith
    , genDiffMediaTypes
    , genDiffMediaType
    , genMatchingPair

    -- * Generating Parameters
    , genParameters
    , genMaybeParameters
    , genDiffParameters

    -- * Rendering Parameters
    , renderParameters
    ) where

import qualified Data.Map                              as Map

import           Control.Monad                         (filterM, liftM, liftM2)
import           Data.ByteString                       (ByteString)
import           Data.CaseInsensitive                  (CI, original)
import           Data.Foldable                         (foldlM)
import           Data.Map                              (fromList)
import           Data.Monoid                           ((<>))
import           Test.QuickCheck.Gen

import           Network.HTTP.Media.Gen
import           Network.HTTP.Media.MediaType.Internal


------------------------------------------------------------------------------
-- | Parameter entry for testing.
type ParamEntry = (CI ByteString, CI ByteString)


------------------------------------------------------------------------------
-- | The MediaType that matches anything.
anything :: MediaType
anything = MediaType "*" "*" Map.empty


------------------------------------------------------------------------------
-- | Generates any kind of MediaType.
genMediaType :: Gen MediaType
genMediaType = oneof [return anything, genSubStar, genConcreteMediaType]


------------------------------------------------------------------------------
-- | Generates a MediaType with just a concrete main type.
genSubStar :: Gen MediaType
genSubStar = do
    main <- genCIByteString
    return $ MediaType main "*" Map.empty


------------------------------------------------------------------------------
-- | Generates a MediaType whose sub type might be *.
genMaybeSubStar :: Gen MediaType
genMaybeSubStar = oneof [genSubStar, genConcreteMediaType]


------------------------------------------------------------------------------
-- | Strips the sub type and parameters from a MediaType.
subStarOf :: MediaType -> MediaType
subStarOf media = media { subType = "*", parameters = Map.empty }


------------------------------------------------------------------------------
-- | Generates a concrete MediaType which may have parameters.
genConcreteMediaType :: Gen MediaType
genConcreteMediaType = do
    main <- genCIByteString
    sub  <- genCIByteString
    params <- oneof [return Map.empty, genParameters]
    return $ MediaType main sub params


------------------------------------------------------------------------------
-- | Generates a concrete MediaType with no parameters.
genWithoutParams :: Gen MediaType
genWithoutParams = do
    main <- genCIByteString
    sub  <- genCIByteString
    return $ MediaType main sub Map.empty


------------------------------------------------------------------------------
-- | Generates a MediaType with at least one parameter.
genWithParams :: Gen MediaType
genWithParams = do
    main   <- genCIByteString
    sub    <- genCIByteString
    params <- genParameters
    return $ MediaType main sub params


------------------------------------------------------------------------------
-- | Strips the parameters from the given MediaType.
stripParams :: MediaType -> MediaType
stripParams media = media { parameters = Map.empty }


------------------------------------------------------------------------------
-- | Generates a different MediaType to the ones in the given list, using the
-- given generator.
genDiffMediaTypesWith :: Gen MediaType -> [MediaType] -> Gen MediaType
genDiffMediaTypesWith gen media = do
    media' <- gen
    if media' `elem` media
        then genDiffMediaTypesWith gen media
        else return media'


------------------------------------------------------------------------------
-- | Generates a different MediaType to the given one, using the given
-- generator.
genDiffMediaTypeWith :: Gen MediaType -> MediaType -> Gen MediaType
genDiffMediaTypeWith gen = genDiffMediaTypesWith gen . (: [])


------------------------------------------------------------------------------
-- | Generates a different MediaType to the ones in the given list.
genDiffMediaTypes :: [MediaType] -> Gen MediaType
genDiffMediaTypes = genDiffMediaTypesWith genMediaType


------------------------------------------------------------------------------
-- | Generates a different MediaType to the given one.
genDiffMediaType :: MediaType -> Gen MediaType
genDiffMediaType = genDiffMediaTypes . (: [])


------------------------------------------------------------------------------
-- | Reuse for 'mayParams' and 'someParams'.
mkGenParams :: (Gen ParamEntry -> Gen [ParamEntry]) -> Gen Parameters
mkGenParams = liftM fromList .
    ($ liftM2 (,) (genDiffCIByteString "q") genCIByteString)


------------------------------------------------------------------------------
-- | Generates some sort of parameters.
genMaybeParameters :: Gen Parameters
genMaybeParameters = mkGenParams listOf


------------------------------------------------------------------------------
-- | Generates at least one parameter.
genParameters :: Gen Parameters
genParameters = mkGenParams listOf1


------------------------------------------------------------------------------
-- | Generates a set of parameters that is not a submap of the given
-- parameters (but not necessarily vice versa).
genDiffParameters :: Parameters -> Gen Parameters
genDiffParameters params = do
    params' <- genParameters
    if params' `Map.isSubmapOf` params
        then genDiffParameters params
        else return params'


------------------------------------------------------------------------------
-- | Generates a set of parameters that is a strict submap of the given
-- parameters.
genSubParameters :: Parameters -> Gen (Maybe Parameters)
genSubParameters params
    | Map.null params = return Nothing
    | otherwise       = Just . Map.fromList <$> genStrictSublist
  where
    list = Map.toList params
    genStrictSublist = do
        sublist <- filterM (const $ choose (False, True)) list
        if sublist == list
            then genStrictSublist
            else return sublist


------------------------------------------------------------------------------
-- | Generates a pair of non-equal MediaType values that are in a 'matches'
-- relation, with the more specific value on the left.
genMatchingPair :: Gen (MediaType, MediaType)
genMatchingPair = do
    a <- oneof [genSubStar, genConcreteMediaType]
    b <- if subType a == "*"
        then return anything
        else oneof $ withSubParameters a : map return [subStarOf a, anything]
    return (a, b)
  where
    withSubParameters a = do
        params <- genSubParameters (parameters a)
        return $ case params of
            Just sub -> a { parameters = sub }
            Nothing  -> subStarOf a


------------------------------------------------------------------------------
-- | Render parameters with a generated amount of whitespace between the
-- semicolons. Note that there is a leading semicolon in front of the
-- parameters, as it is expected that this will always be attached to
-- a preceding 'MediaType' rendering.
renderParameters :: Parameters -> Gen ByteString
renderParameters params = foldlM pad "" (Map.toList params)
  where
    pad s (k, v) =
        (s <>) . (<> original k <> "=" <> original v) <$> padString ";"