Primitives.hs

{-# LANGUAGE OverloadedStrings #-}

-- | Primitive generators for basic Haskell types.
--
-- All generators in this module use the 'Basic' constructor, sending a CBOR
-- schema to the server and decoding the response with a type-appropriate
-- transform.
module Hegel.Generator.Primitives
  ( -- * Scalar generators
    booleans
  , integers
  , floats
  , text
  , binary
  , just

    -- * Range options
  , RangeOpts (..)
  , defaultRangeOpts

    -- * Float options
  , FloatOpts (..)
  , defaultFloatOpts

    -- * Format generators
  , emails
  , urls
  , dates
  , times
  , datetimes
  , domains
  , ipv4Addresses
  , ipv6Addresses
  , fromRegex
  ) where

import Codec.CBOR.Term (Term (..))
import Data.ByteString (ByteString)
import Data.Default (Default (def))
import Data.Maybe (catMaybes, isJust)
import Data.Text (Text)

import Hegel.Generator (Generator (..))
import Hegel.Generator.Range
  ( RangeOpts (..)
  , defaultRangeOpts
  , validateSizeBounds
  )

-- ----------------------------------------------------------------------------
-- CBOR extraction helpers
-- ----------------------------------------------------------------------------

-- | Extract a 'Bool' from a CBOR term.
extractBool :: Term -> Bool
extractBool (TBool b) = b
extractBool t         = error $ "extractBool: expected TBool, got " ++ show t

-- | Extract an 'Int' from a CBOR term.
extractInt :: Term -> Int
extractInt (TInt n)     = n
extractInt (TInteger n) = fromIntegral n
extractInt t            = error $ "extractInt: expected TInt/TInteger, got " ++ show t

-- | Extract a 'Double' from a CBOR term.
extractFloat :: Term -> Double
extractFloat (THalf f)    = realToFrac f
extractFloat (TFloat f)   = realToFrac f
extractFloat (TDouble f)  = f
extractFloat (TInt n)     = fromIntegral n
extractFloat (TInteger n) = fromIntegral n
extractFloat t            = error $ "extractFloat: expected float term, got " ++ show t

-- | Extract 'Text' from a CBOR term.
extractText :: Term -> Text
extractText (TString s) = s
extractText t           = error $ "extractText: expected TString, got " ++ show t

-- | Extract 'ByteString' from a CBOR term.
extractBytes :: Term -> ByteString
extractBytes (TBytes b) = b
extractBytes t          = error $ "extractBytes: expected TBytes, got " ++ show t

-- ----------------------------------------------------------------------------
-- Scalar generators
-- ----------------------------------------------------------------------------

-- | Generator for boolean values.
--
-- Schema: @{\"type\": \"boolean\"}@
booleans :: Generator Bool
booleans = Basic
  (TMap [(TString "type", TString "boolean")])
  extractBool

-- | Generator for integer values within optional bounds.
--
-- Schema: @{\"type\": \"integer\", \"min_value\"?: N, \"max_value\"?: N}@
integers :: RangeOpts Int -> Generator Int
integers RangeOpts {rangeMin = minVal, rangeMax = maxVal} =
  case (minVal, maxVal) of
    (Just lo, Just hi) | lo > hi ->
      error $ "integers: max_value=" ++ show hi ++ " < min_value=" ++ show lo
    _ -> ()
  `seq` Basic (TMap pairs) extractInt
  where
    pairs = catMaybes
      [ Just (TString "type", TString "integer")
      , fmap (\v -> (TString "min_value", TInt v)) minVal
      , fmap (\v -> (TString "max_value", TInt v)) maxVal
      ]

-- | Options for the floating-point generator.
data FloatOpts = FloatOpts
  { floatBounds        :: !(RangeOpts Double)
  , floatExcludeMin    :: !Bool
  , floatExcludeMax    :: !Bool
  , floatAllowNan      :: !(Maybe Bool)
  , floatAllowInfinity :: !(Maybe Bool)
  } deriving (Eq, Show)

instance Default FloatOpts where
  def = FloatOpts
    { floatBounds        = def
    , floatExcludeMin    = False
    , floatExcludeMax    = False
    , floatAllowNan      = Nothing
    , floatAllowInfinity = Nothing
    }

-- | Default float options: no bounds, no exclusions, nan/infinity determined
-- by bounds. Equivalent to 'def'; new code can use 'def' directly.
defaultFloatOpts :: FloatOpts
defaultFloatOpts = def

-- | Generator for floating-point values.
--
-- Schema: @{\"type\": \"float\", \"allow_nan\": bool, \"allow_infinity\": bool,
-- \"width\": 64, \"exclude_min\": bool, \"exclude_max\": bool,
-- \"min_value\"?: f, \"max_value\"?: f}@
--
-- Defaults follow Hypothesis:
--
-- * @allow_nan@: 'True' only when no bounds are set
-- * @allow_infinity@: 'True' when at most one bound is set
floats :: FloatOpts -> Generator Double
floats FloatOpts
  { floatBounds = RangeOpts {rangeMin = minVal, rangeMax = maxVal}
  , floatExcludeMin = excludeMin
  , floatExcludeMax = excludeMax
  , floatAllowNan = allowNan
  , floatAllowInfinity = allowInfinity
  } =
  -- Validation
  (if effAllowNan && (hasMin || hasMax)
     then error "floats: cannot have allow_nan=True with min_value or max_value"
     else ())
  `seq`
  (case (minVal, maxVal) of
     (Just lo, Just hi) | lo > hi ->
       error $ "floats: no floats between min_value=" ++ show lo
            ++ " and max_value=" ++ show hi
     _ -> ())
  `seq`
  (if effAllowInfinity && hasMin && hasMax
     then error "floats: cannot have allow_infinity=True with both min_value and max_value"
     else ())
  `seq`
  Basic (TMap pairs) extractFloat
  where
    hasMin = isJust minVal
    hasMax = isJust maxVal
    effAllowNan = case allowNan of
      Just v  -> v
      Nothing -> not hasMin && not hasMax
    effAllowInfinity = case allowInfinity of
      Just v  -> v
      Nothing -> not hasMin || not hasMax
    pairs =
      [ (TString "type",           TString "float")
      , (TString "allow_nan",      TBool effAllowNan)
      , (TString "allow_infinity", TBool effAllowInfinity)
      , (TString "exclude_min",    TBool excludeMin)
      , (TString "exclude_max",    TBool excludeMax)
      , (TString "width",          TInt 64)
      ]
      ++ catMaybes
      [ fmap (\v -> (TString "min_value", TDouble v)) minVal
      , fmap (\v -> (TString "max_value", TDouble v)) maxVal
      ]

-- | Generator for Unicode text strings.
--
-- Schema: @{\"type\": \"string\", \"min_size\": N, \"max_size\"?: N}@
text :: RangeOpts Int -> Generator Text
text opts =
  let (ms, maxSize) = validateSizeBounds "text" opts
      pairs = catMaybes
        [ Just (TString "type",     TString "string")
        , Just (TString "min_size", TInt ms)
        , fmap (\v -> (TString "max_size", TInt v)) maxSize
        ]
  in
  Basic (TMap pairs) extractText

-- | Generator for binary byte strings.
--
-- Schema: @{\"type\": \"binary\", \"min_size\": N, \"max_size\"?: N}@
binary :: RangeOpts Int -> Generator ByteString
binary opts =
  let (ms, maxSize) = validateSizeBounds "binary" opts
      pairs = catMaybes
        [ Just (TString "type",     TString "binary")
        , Just (TString "min_size", TInt ms)
        , fmap (\v -> (TString "max_size", TInt v)) maxSize
        ]
  in
  Basic (TMap pairs) extractBytes

-- | Generator that always produces the given constant value.
--
-- Schema: @{\"const\": null}@. The transform ignores the server result.
just :: a -> Generator a
just value = Basic
  (TMap [(TString "const", TNull)])
  (const value)

-- ----------------------------------------------------------------------------
-- Format generators
-- ----------------------------------------------------------------------------

-- | Generator for valid email address strings.
emails :: Generator Text
emails = Basic
  (TMap [(TString "type", TString "email")])
  extractText

-- | Generator for valid URL strings.
urls :: Generator Text
urls = Basic
  (TMap [(TString "type", TString "url")])
  extractText

-- | Generator for ISO 8601 date strings (YYYY-MM-DD).
dates :: Generator Text
dates = Basic
  (TMap [(TString "type", TString "date")])
  extractText

-- | Generator for time strings.
times :: Generator Text
times = Basic
  (TMap [(TString "type", TString "time")])
  extractText

-- | Generator for ISO 8601 datetime strings.
datetimes :: Generator Text
datetimes = Basic
  (TMap [(TString "type", TString "datetime")])
  extractText

-- | Generator for domain name strings.
--
-- If a maximum length is provided, generated domains will not exceed that
-- length. Valid range: 4 to 255.
domains :: Maybe Int -> Generator Text
domains maxLength =
  (case maxLength of
     Just ml | ml < 4 || ml > 255 ->
       error $ "domains: max_length=" ++ show ml ++ " must be between 4 and 255"
     _ -> ())
  `seq`
  Basic (TMap pairs) extractText
  where
    pairs = catMaybes
      [ Just (TString "type", TString "domain")
      , fmap (\ml -> (TString "max_length", TInt ml)) maxLength
      ]

-- | Generator for IPv4 address strings (dotted decimal).
ipv4Addresses :: Generator Text
ipv4Addresses = Basic
  (TMap [(TString "type", TString "ipv4")])
  extractText

-- | Generator for IPv6 address strings (colon hex).
ipv6Addresses :: Generator Text
ipv6Addresses = Basic
  (TMap [(TString "type", TString "ipv6")])
  extractText

-- | Generator for strings matching a regular expression.
--
-- When @fullmatch@ is 'True', the entire string must match the pattern.
-- When 'False', a substring match suffices.
fromRegex :: Text -> Bool -> Generator Text
fromRegex regexPattern fullmatch = Basic
  (TMap
    [ (TString "type",      TString "regex")
    , (TString "pattern",   TString regexPattern)
    , (TString "fullmatch", TBool fullmatch)
    ])
  extractText