hegel (empty) → 0.1.0

raw patch · 24 files changed

+4025/−0 lines, 24 filesdep +aesondep +arraydep +async

Dependencies added: aeson, array, async, base, bytestring, cborg, containers, data-default, digest, directory, hegel, hspec, process, stm, text

Files

• conformance/TestBinary.hs +36/−0
• conformance/TestBooleans.hs +13/−0
• conformance/TestFloats.hs +76/−0
• conformance/TestHashmaps.hs +86/−0
• conformance/TestIntegers.hs +35/−0
• conformance/TestLists.hs +57/−0
• conformance/TestSampledFrom.hs +32/−0
• conformance/TestText.hs +37/−0
• hegel.cabal +168/−0
• src/Hegel.hs +153/−0
• src/Hegel/Client.hs +521/−0
• src/Hegel/Conformance.hs +43/−0
• src/Hegel/Connection.hs +648/−0
• src/Hegel/Generator.hs +385/−0
• src/Hegel/Generator/Collections.hs +88/−0
• src/Hegel/Generator/Combinators.hs +231/−0
• src/Hegel/Generator/Primitives.hs +303/−0
• src/Hegel/Generator/Range.hs +55/−0
• src/Hegel/Protocol.hs +357/−0
• src/Hegel/Session.hs +397/−0
• test/Hegel/ClientSpec.hs +41/−0
• test/Hegel/IntegrationSpec.hs +121/−0
• test/Hegel/ProtocolSpec.hs +141/−0
• test/Spec.hs +1/−0

@@ -0,0 +1,36 @@+{-# LANGUAGE OverloadedStrings #-}++-- | Conformance binary: generates binary byte strings and writes metrics.+module Main (main) where++import qualified Data.Aeson as Aeson+import Data.Aeson (Value (..))+import qualified Data.ByteString as BS+import qualified Data.ByteString.Lazy.Char8 as LBS+import Data.Maybe (fromMaybe, listToMaybe)+import qualified Data.Map.Strict as Map+import Hegel+import System.Environment (getArgs)++parseParams :: IO (Map.Map String Value)+parseParams = do+  args <- getArgs+  pure $+    fromMaybe Map.empty $+      Aeson.decode . LBS.pack =<< listToMaybe args++getIntParam :: Map.Map String Value -> String -> Maybe Int+getIntParam m k = round <$> (getNumber =<< Map.lookup k m)+  where+    getNumber (Number n) = Just n+    getNumber _ = Nothing++main :: IO ()+main = do+  params <- parseParams+  let minSize = getIntParam params "min_size"+  let maxSize = getIntParam params "max_size"+  testCases <- getTestCases+  runHegelTest (\settings -> settings { settingsTestCases = testCases }) $ \tc -> do+    b <- draw tc (binary def { rangeMin = minSize, rangeMax = maxSize })+    writeMetrics [("length", show (BS.length b))]

@@ -0,0 +1,13 @@+{-# LANGUAGE OverloadedStrings #-}++-- | Conformance binary: generates boolean values and writes metrics.+module Main (main) where++import Hegel++main :: IO ()+main = do+  testCases <- getTestCases+  runHegelTest (\settings -> settings { settingsTestCases = testCases }) $ \tc -> do+    b <- draw tc booleans+    writeMetrics [("value", if b then "true" else "false")]

@@ -0,0 +1,76 @@+{-# LANGUAGE OverloadedStrings #-}++-- | Conformance binary: generates float values and writes metrics.+module Main (main) where++import qualified Data.Aeson as Aeson+import Data.Aeson (Value (..))+import qualified Data.ByteString.Lazy.Char8 as LBS+import Data.Maybe (fromMaybe, listToMaybe)+import qualified Data.Map.Strict as Map+import Hegel+import System.Environment (getArgs)++parseParams :: IO (Map.Map String Value)+parseParams = do+  args <- getArgs+  pure $+    fromMaybe Map.empty $+      Aeson.decode . LBS.pack =<< listToMaybe args++getDoubleParam :: Map.Map String Value -> String -> Maybe Double+getDoubleParam m k = realToFrac <$> (getNumber =<< Map.lookup k m)+  where+    getNumber (Number n) = Just n+    getNumber _ = Nothing++getBoolParam :: Map.Map String Value -> String -> Maybe Bool+getBoolParam m k = getBool =<< Map.lookup k m+  where+    getBool (Bool b) = Just b+    getBool _ = Nothing++getBoolParamDefault :: Map.Map String Value -> String -> Bool -> Bool+getBoolParamDefault m k defaultValue = fromMaybe defaultValue (getBoolParam m k)++-- | Format a float for JSON output. NaN becomes "null", +Inf becomes "1e308",+-- -Inf becomes "-1e308", otherwise show the number.+formatFloat :: Double -> String+formatFloat v+  | isNaN v = "null"+  | isInfinite v = if v > 0 then "1e308" else "-1e308"+  | otherwise = show v++boolStr :: Bool -> String+boolStr True = "true"+boolStr False = "false"++main :: IO ()+main = do+  params <- parseParams+  let minVal = getDoubleParam params "min_value"+  let maxVal = getDoubleParam params "max_value"+  let excludeMin = getBoolParamDefault params "exclude_min" False+  let excludeMax = getBoolParamDefault params "exclude_max" False+  let allowNan = getBoolParam params "allow_nan"+  let allowInf = getBoolParam params "allow_infinity"+  let opts =+        def+          { floatBounds =+              RangeOpts+                { rangeMin = minVal,+                  rangeMax = maxVal+                },+            floatExcludeMin = excludeMin,+            floatExcludeMax = excludeMax,+            floatAllowNan = allowNan,+            floatAllowInfinity = allowInf+          }+  testCases <- getTestCases+  runHegelTest (\settings -> settings { settingsTestCases = testCases }) $ \tc -> do+    v <- draw tc (floats opts)+    writeMetrics+      [ ("value", formatFloat v),+        ("is_nan", boolStr (isNaN v)),+        ("is_infinite", boolStr (isInfinite v))+      ]

@@ -0,0 +1,86 @@+{-# LANGUAGE OverloadedStrings #-}++-- | Conformance binary: generates hash maps (dicts) and writes metrics.+module Main (main) where++import qualified Data.Aeson as Aeson+import Data.Aeson (Value (..))+import qualified Data.ByteString.Lazy.Char8 as LBS+import Data.Maybe (fromMaybe, listToMaybe)+import qualified Data.Map.Strict as Map+import Data.Text (Text)+import Hegel+import System.Environment (getArgs)++parseParams :: IO (Map.Map String Value)+parseParams = do+  args <- getArgs+  pure $+    fromMaybe Map.empty $+      Aeson.decode . LBS.pack =<< listToMaybe args++getIntParam :: Map.Map String Value -> String -> Maybe Int+getIntParam m k = round <$> (getNumber =<< Map.lookup k m)+  where+    getNumber (Number n) = Just n+    getNumber _ = Nothing++getIntParamDefault :: Map.Map String Value -> String -> Int -> Int+getIntParamDefault m k defaultValue = fromMaybe defaultValue (getIntParam m k)++getTextParam :: Map.Map String Value -> String -> Maybe Text+getTextParam m k = getText =<< Map.lookup k m+  where+    getText (Aeson.String t) = Just t+    getText _ = Nothing++intOrNull :: Maybe Int -> String+intOrNull = maybe "null" show++main :: IO ()+main = do+  params <- parseParams+  let minSize = getIntParamDefault params "min_size" 0+  let maxSize = getIntParamDefault params "max_size" 10+  let keyType = fromMaybe "integer" (getTextParam params "key_type")+  let minKey = getIntParamDefault params "min_key" (-1000)+  let maxKey = getIntParamDefault params "max_key" 1000+  let minValBound = getIntParamDefault params "min_value" (-1000)+  let maxValBound = getIntParamDefault params "max_value" 1000+  testCases <- getTestCases+  if keyType == "string"+    then runHegelTest (\settings -> settings { settingsTestCases = testCases }) $ \tc -> do+      let keyGen = text def { rangeMin = Just 1, rangeMax = Just 10 }+      let valGen = integers def { rangeMin = Just minValBound, rangeMax = Just maxValBound }+      let mapGen = hashmaps keyGen valGen def { rangeMin = Just minSize, rangeMax = Just maxSize }+      pairs <- draw tc mapGen+      let len = length pairs+      let vals = map snd pairs+      let minVal = if null vals then Nothing else Just (minimum vals)+      let maxVal = if null vals then Nothing else Just (maximum vals)+      writeMetrics+        [ ("size", show len),+          ("min_key", "null"),+          ("max_key", "null"),+          ("min_value", intOrNull minVal),+          ("max_value", intOrNull maxVal)+        ]+    else runHegelTest (\settings -> settings { settingsTestCases = testCases }) $ \tc -> do+      let keyGen = integers def { rangeMin = Just minKey, rangeMax = Just maxKey }+      let valGen = integers def { rangeMin = Just minValBound, rangeMax = Just maxValBound }+      let mapGen = hashmaps keyGen valGen def { rangeMin = Just minSize, rangeMax = Just maxSize }+      pairs <- draw tc mapGen+      let len = length pairs+      let keys = map fst pairs+      let vals = map snd pairs+      let minKeyResult = if null keys then Nothing else Just (minimum keys)+      let maxKeyResult = if null keys then Nothing else Just (maximum keys)+      let minValResult = if null vals then Nothing else Just (minimum vals)+      let maxValResult = if null vals then Nothing else Just (maximum vals)+      writeMetrics+        [ ("size", show len),+          ("min_key", intOrNull minKeyResult),+          ("max_key", intOrNull maxKeyResult),+          ("min_value", intOrNull minValResult),+          ("max_value", intOrNull maxValResult)+        ]

@@ -0,0 +1,35 @@+{-# LANGUAGE OverloadedStrings #-}++-- | Conformance binary: generates integer values and writes metrics.+module Main (main) where++import qualified Data.Aeson as Aeson+import Data.Aeson (Value (..))+import qualified Data.ByteString.Lazy.Char8 as LBS+import Data.Maybe (fromMaybe, listToMaybe)+import qualified Data.Map.Strict as Map+import Hegel+import System.Environment (getArgs)++parseParams :: IO (Map.Map String Value)+parseParams = do+  args <- getArgs+  pure $+    fromMaybe Map.empty $+      Aeson.decode . LBS.pack =<< listToMaybe args++getIntParam :: Map.Map String Value -> String -> Maybe Int+getIntParam m k = round <$> (getNumber =<< Map.lookup k m)+  where+    getNumber (Number n) = Just n+    getNumber _ = Nothing++main :: IO ()+main = do+  params <- parseParams+  let minVal = getIntParam params "min_value"+  let maxVal = getIntParam params "max_value"+  testCases <- getTestCases+  runHegelTest (\settings -> settings { settingsTestCases = testCases }) $ \tc -> do+    n <- draw tc (integers def { rangeMin = minVal, rangeMax = maxVal })+    writeMetrics [("value", show n)]

@@ -0,0 +1,57 @@+{-# LANGUAGE OverloadedStrings #-}++-- | Conformance binary: generates lists of integers and writes metrics.+--+-- Uses filtered elements (CompositeList path) so that new_collection and+-- collection_more commands are sent -- required for error-mode conformance+-- tests (stop_test_on_collection_more, stop_test_on_new_collection).+module Main (main) where++import qualified Data.Aeson as Aeson+import Data.Aeson (Value (..))+import qualified Data.ByteString.Lazy.Char8 as LBS+import Data.Maybe (fromMaybe, listToMaybe)+import qualified Data.Map.Strict as Map+import Hegel+import System.Environment (getArgs)++parseParams :: IO (Map.Map String Value)+parseParams = do+  args <- getArgs+  pure $+    fromMaybe Map.empty $+      Aeson.decode . LBS.pack =<< listToMaybe args++getIntParam :: Map.Map String Value -> String -> Maybe Int+getIntParam m k = round <$> (getNumber =<< Map.lookup k m)+  where+    getNumber (Number n) = Just n+    getNumber _ = Nothing++intOrNull :: Maybe Int -> String+intOrNull = maybe "null" show++main :: IO ()+main = do+  params <- parseParams+  let minSize = getIntParam params "min_size"+  let maxSize = getIntParam params "max_size"+  let minVal = getIntParam params "min_value"+  let maxVal = getIntParam params "max_value"+  testCases <- getTestCases+  runHegelTest (\settings -> settings { settingsTestCases = testCases }) $ \tc -> do+    -- Use gfilter (const True) to force the CompositeList path, which sends+    -- new_collection and collection_more commands. This is required so that+    -- the error-mode conformance tests (stop_test_on_collection_more,+    -- stop_test_on_new_collection) work correctly.+    let elemGen = gfilter (const True) (integers def { rangeMin = minVal, rangeMax = maxVal })+    let listGen = lists elemGen def { rangeMin = minSize, rangeMax = maxSize }+    items <- draw tc listGen+    let len = length items+    let minElem = if null items then Nothing else Just (minimum items)+    let maxElem = if null items then Nothing else Just (maximum items)+    writeMetrics+      [ ("size", show len),+        ("min_element", intOrNull minElem),+        ("max_element", intOrNull maxElem)+      ]

@@ -0,0 +1,32 @@+{-# LANGUAGE OverloadedStrings #-}++-- | Conformance binary: generates sampled_from values and writes metrics.+module Main (main) where++import qualified Data.Aeson as Aeson+import Data.Aeson (Value (..))+import qualified Data.Aeson.Types as Aeson+import qualified Data.ByteString.Lazy.Char8 as LBS+import Data.Maybe (fromMaybe, listToMaybe)+import qualified Data.Map.Strict as Map+import Hegel+import System.Environment (getArgs)++parseParams :: IO (Map.Map String Value)+parseParams = do+  args <- getArgs+  pure $+    fromMaybe Map.empty $+      Aeson.decode . LBS.pack =<< listToMaybe args++getIntArray :: Map.Map String Value -> String -> [Int]+getIntArray m k = fromMaybe [] $ Map.lookup k m >>= Aeson.parseMaybe Aeson.parseJSON++main :: IO ()+main = do+  params <- parseParams+  let options = getIntArray params "options"+  testCases <- getTestCases+  runHegelTest (\settings -> settings { settingsTestCases = testCases }) $ \tc -> do+    v <- draw tc (sampledFrom options)+    writeMetrics [("value", show v)]

@@ -0,0 +1,37 @@+{-# LANGUAGE OverloadedStrings #-}++-- | Conformance binary: generates text values and writes metrics.+module Main (main) where++import qualified Data.Aeson as Aeson+import Data.Aeson (Value (..))+import qualified Data.ByteString.Lazy.Char8 as LBS+import Data.Maybe (fromMaybe, listToMaybe)+import qualified Data.Map.Strict as Map+import qualified Data.Text as T+import Hegel+import System.Environment (getArgs)++parseParams :: IO (Map.Map String Value)+parseParams = do+  args <- getArgs+  pure $+    fromMaybe Map.empty $+      Aeson.decode . LBS.pack =<< listToMaybe args++getIntParam :: Map.Map String Value -> String -> Maybe Int+getIntParam m k = round <$> (getNumber =<< Map.lookup k m)+  where+    getNumber (Number n) = Just n+    getNumber _ = Nothing++main :: IO ()+main = do+  params <- parseParams+  let minSize = getIntParam params "min_size"+  let maxSize = getIntParam params "max_size"+  testCases <- getTestCases+  runHegelTest (\settings -> settings { settingsTestCases = testCases }) $ \tc -> do+    t <- draw tc (text def { rangeMin = minSize, rangeMax = maxSize })+    -- T.length counts Unicode codepoints+    writeMetrics [("length", show (T.length t))]

@@ -0,0 +1,168 @@+cabal-version: 3.0+name:          hegel+version:       0.1.0+synopsis:      Property-based testing powered by Hypothesis+description:+  Hegel is a Haskell property-based testing library backed by Hypothesis.+  It provides a generator API, an integration test runner, and a wire+  protocol client for driving Hegel from Haskell code.+maintainer:    Mark Wotton <mwotton@gmail.com>+category:      Testing+license:       MIT+build-type:    Simple++common shared+  ghc-options:      -Wall -Wcompat -threaded+  default-language: GHC2021+  build-depends:    data-default >=0.7 && <0.9++library+  import:          shared+  hs-source-dirs:  src+  exposed-modules:+    Hegel+    Hegel.Client+    Hegel.Conformance+    Hegel.Connection+    Hegel.Generator+    Hegel.Generator.Collections+    Hegel.Generator.Combinators+    Hegel.Generator.Primitives+    Hegel.Protocol+    Hegel.Session+  other-modules:+    Hegel.Generator.Range++  build-depends:+    , array         >=0.5      && <0.6+    , async         >=2.2      && <2.3+    , base          >=4.18  && <5+    , bytestring    >=0.11     && <0.13+    , cborg         >=0.2.9    && <0.3+    , containers    >=0.6      && <0.8+    , digest        >=0.0.2    && <0.1+    , directory     >=1.3      && <1.4+    , process       >=1.6      && <1.7+    , stm           >=2.5      && <2.6+    , text          >=2.0      && <2.2++test-suite hegel-test+  import:         shared+  type:           exitcode-stdio-1.0+  hs-source-dirs: test+  main-is:        Spec.hs+  other-modules:+    Hegel.ProtocolSpec+    Hegel.ClientSpec+    Hegel.IntegrationSpec++  build-depends:+    , base+    , bytestring+    , cborg+    , hegel+    , hspec+    , process+    , stm+    , text++  build-tool-depends:+    hspec-discover:hspec-discover++executable test-booleans+  import:         shared+  hs-source-dirs: conformance+  main-is:        TestBooleans.hs+  build-depends:+    , aeson        >=2.2       && <2.3+    , base+    , hegel+    , text++executable test-integers+  import:         shared+  hs-source-dirs: conformance+  main-is:        TestIntegers.hs+  build-depends:+    , aeson        >=2.2       && <2.3+    , base+    , bytestring+    , containers+    , hegel+    , text++executable test-floats+  import:         shared+  hs-source-dirs: conformance+  main-is:        TestFloats.hs+  build-depends:+    , aeson        >=2.2       && <2.3+    , base+    , bytestring+    , containers+    , hegel+    , text++executable test-text+  import:         shared+  hs-source-dirs: conformance+  main-is:        TestText.hs+  build-depends:+    , aeson        >=2.2       && <2.3+    , base+    , bytestring+    , containers+    , hegel+    , text++executable test-binary+  import:         shared+  hs-source-dirs: conformance+  main-is:        TestBinary.hs+  build-depends:+    , aeson        >=2.2       && <2.3+    , base+    , bytestring+    , containers+    , hegel+    , text++executable test-lists+  import:         shared+  hs-source-dirs: conformance+  main-is:        TestLists.hs+  build-depends:+    , aeson        >=2.2       && <2.3+    , base+    , bytestring+    , containers+    , hegel+    , text++executable test-sampled-from+  import:         shared+  hs-source-dirs: conformance+  main-is:        TestSampledFrom.hs+  build-depends:+    , aeson        >=2.2       && <2.3+    , base+    , bytestring+    , containers+    , hegel+    , text++executable test-hashmaps+  import:         shared+  hs-source-dirs: conformance+  main-is:        TestHashmaps.hs+  build-depends:+    , aeson        >=2.2       && <2.3+    , base+    , bytestring+    , containers+    , hegel+    , text++source-repository head+  type:     git+  location: https://github.com/lambdamechanic/hegel-haskell.git

@@ -0,0 +1,153 @@+-- | Hegel is a property-based testing library for Haskell. Hegel is based on+-- <https://github.com/hypothesisworks/hypothesis Hypothesis>, using the+-- <https://hegel.dev/ Hegel> protocol.+--+-- = Getting started+--+-- @+-- import Data.Default (def)+-- import Hegel+--+-- main :: IO ()+-- main = 'runHegelTest_' $ \\tc -> do+--   n <- 'draw' tc ('integers' def)+--   assert (n == n) "integer not equal to itself"+-- @+module Hegel+  ( -- * Running tests+    runHegelTest,+    runHegelTest_,+    TestCase,+    Settings+      ( settingsTestCases+      , settingsVerbosity+      , settingsSeed+      , settingsDerandomize+      , settingsDatabase+      , settingsSuppressHealthCheck+      ),+    defaultSettings,+    def,+    HealthCheck (..),+    Verbosity (..),+    Database (..),++    -- * Drawing values+    draw,+    assume,+    assert,+    failure,+    note,+    target,++    -- * Generators+    Generator,+    gmap,+    flatMap,+    gfilter,++    -- ** Primitives+    booleans,+    integers,+    floats,+    RangeOpts (..),+    defaultRangeOpts,+    FloatOpts (..),+    defaultFloatOpts,+    text,+    binary,+    just,++    -- ** Collections+    lists,+    hashmaps,++    -- ** Combinators+    sampledFrom,+    oneOf,+    optional,+    tuples2,+    tuples3,+    tuples4,+    ipAddresses,+    ipv4Addresses,+    ipv6Addresses,++    -- ** Formats+    emails,+    urls,+    domains,+    dates,+    times,+    datetimes,+    fromRegex,++    -- * Conformance helpers+    getTestCases,+    writeMetrics,++    -- * Exceptions+    AssumeRejected (..),+    DataExhausted (..),+    HegelTestFailure (..),+  )+where++import Data.Default (def)+import Hegel.Client+  ( AssumeRejected (..),+    DataExhausted (..),+    Database (..),+    HealthCheck (..),+    HegelTestFailure (..),+    Settings+      ( settingsTestCases+      , settingsVerbosity+      , settingsSeed+      , settingsDerandomize+      , settingsDatabase+      , settingsSuppressHealthCheck+      ),+    TestCase,+    Verbosity (..),+    assume,+    assert,+    defaultSettings,+    note,+    target,+    failure,+  )+import Hegel.Conformance (getTestCases, writeMetrics)+import Hegel.Generator (Generator, draw, flatMap, gfilter, gmap)+import Hegel.Generator.Collections (hashmaps, lists)+import Hegel.Generator.Combinators+  ( ipAddresses,+    oneOf,+    optional,+    sampledFrom,+    tuples2,+    tuples3,+    tuples4,+  )+import Hegel.Generator.Primitives+  ( FloatOpts (..),+    RangeOpts (..),+    binary,+    booleans,+    dates,+    datetimes,+    defaultFloatOpts,+    defaultRangeOpts,+    domains,+    emails,+    floats,+    fromRegex,+    integers,+    ipv4Addresses,+    ipv6Addresses,+    just,+    text,+    times,+    urls,+  )+import Hegel.Session (runHegelTest, runHegelTest_)

@@ -0,0 +1,521 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}++-- | Test runner and lifecycle management for Hegel.+--+-- This module implements the client-side logic for running property-based+-- tests against a Hegel server. It manages:+--+-- * Test lifecycle (run_test, test_case events, mark_complete)+-- * Helper functions (assume, note, target, generate_from_schema)+-- * Origin extraction for error reporting+module Hegel.Client+  ( -- * Exceptions+    AssumeRejected (..)+  , DataExhausted (..)+  , HegelTestFailure (..)++    -- * Health checks+  , HealthCheck (..)+  , healthCheckToString++    -- * Verbosity and database settings+  , Verbosity (..)+  , Database (..)+  , Settings+      ( settingsTestCases+      , settingsVerbosity+      , settingsSeed+      , settingsDerandomize+      , settingsDatabase+      , settingsSuppressHealthCheck+      )+  , defaultSettings++    -- * Test case state+  , TestCase (..)++    -- * Client+  , HegelClient (..)+  , createClient++    -- * Test operations+  , generateFromSchema+  , assume+  , assert+  , failure+  , note+  , target+  , startSpan+  , stopSpan+  , runTestCase+  , runTest+  ) where++import Codec.CBOR.Term (Term (..))+import Control.Concurrent.MVar+import Control.Exception hiding (assert)+import Control.Monad (replicateM_, when, unless, void)+import Data.Default (Default (def))+import Data.IORef+import Data.Text (Text)+import qualified Data.Text as T+import GHC.Stack+  ( CallStack+  , HasCallStack+  , SrcLoc (..)+  , callStack+  , getCallStack+  , prettyCallStack+  , withFrozenCallStack+  )+import System.IO (hPutStrLn, stderr)++import Hegel.Connection+import Hegel.Protocol (encodeTerm, extractInt, extractMap, extractText)+++-- ---------------------------------------------------------------------------+-- Exceptions+-- ---------------------------------------------------------------------------++-- | Raised when 'assume' is called with a 'False' condition.+data AssumeRejected = AssumeRejected+  deriving (Show)++instance Exception AssumeRejected++-- | Raised when the server runs out of test data (StopTest).+data DataExhausted = DataExhausted+  deriving (Show)++instance Exception DataExhausted++-- | Raised when a property test fails.+newtype HegelTestFailure = HegelTestFailure String+  deriving (Show)++instance Exception HegelTestFailure++-- | Raised by Hegel's assertion helpers. Carries a call stack so we can report+-- a stable source location to the server while still surfacing the full error+-- message on the final replayed failure.+data AssertionFailure = AssertionFailure+  { assertionFailureMessage :: String+  , assertionFailureCallStack :: CallStack+  }++instance Show AssertionFailure where+  show AssertionFailure {..}+    | null (getCallStack assertionFailureCallStack) = assertionFailureMessage+    | otherwise =+        assertionFailureMessage+          ++ "\n"+          ++ prettyCallStack assertionFailureCallStack++instance Exception AssertionFailure where+  displayException = show+++-- ---------------------------------------------------------------------------+-- Health checks+-- ---------------------------------------------------------------------------++-- | Health checks that can be suppressed during test execution.+data HealthCheck+  = FilterTooMuch+  | TooSlow+  | TestCasesTooLarge+  | LargeInitialTestCase+  deriving (Show, Eq)++-- | Returns the wire protocol name for a health check.+healthCheckToString :: HealthCheck -> Text+healthCheckToString FilterTooMuch = "filter_too_much"+healthCheckToString TooSlow = "too_slow"+healthCheckToString TestCasesTooLarge = "test_cases_too_large"+healthCheckToString LargeInitialTestCase = "large_initial_test_case"+++-- ---------------------------------------------------------------------------+-- Verbosity and database settings+-- ---------------------------------------------------------------------------++-- | Controls how much output Hegel produces during test runs.+data Verbosity = Quiet | Normal | Verbose | Debug+  deriving (Show, Eq)++-- | The database setting: unset, disabled, or a path.+data Database+  = Unset+  | Disabled+  | DatabasePath FilePath+  deriving (Show, Eq)++-- | Configuration for a Hegel test run.+data Settings = Settings+  { settingsTestCases :: Int+  , settingsVerbosity :: Verbosity+  , settingsSeed :: Maybe Int+  , settingsDerandomize :: Bool+  , settingsDatabase :: Database+  , settingsSuppressHealthCheck :: [HealthCheck]+  } deriving (Show, Eq)++instance Default Settings where+  def = Settings+    { settingsTestCases = 100+    , settingsVerbosity = Normal+    , settingsSeed = Nothing+    , settingsDerandomize = False+    , settingsDatabase = Unset+    , settingsSuppressHealthCheck = []+    }+++-- | Pure baseline settings before any runtime-specific overrides are applied.+defaultSettings :: Settings+defaultSettings = def+++-- ---------------------------------------------------------------------------+-- Test case state+-- ---------------------------------------------------------------------------++-- | Per-test-case state passed to the test function.+data TestCase = TestCase+  { tcChannel :: Channel+    -- ^ The data channel for this test case.+  , tcIsFinal :: Bool+    -- ^ Whether this is the final (replay) run.+  , tcTestAborted :: IORef Bool+    -- ^ Set to 'True' when the server signals StopTest.+  }+++-- ---------------------------------------------------------------------------+-- Client+-- ---------------------------------------------------------------------------++-- | Supported protocol version range.+supportedProtocolLo :: Double+supportedProtocolLo = 0.6++supportedProtocolHi :: Double+supportedProtocolHi = 0.7++-- | Hegel client for running property-based tests.+data HegelClient = HegelClient+  { clientConnection :: Connection+  , clientControl :: Channel+  , clientLock :: MVar ()+  }++-- | Creates a new client from a connection. The connection must not yet have+-- had its handshake performed. Validates the protocol version is in range+-- 0.1 through 0.7.+createClient :: Connection -> IO HegelClient+createClient conn = do+  versionStr <- sendHandshake conn+  let serverVersion = read versionStr :: Double+  when (serverVersion < supportedProtocolLo || serverVersion > supportedProtocolHi) $+    fail $ "hegel-haskell supports protocol versions "+      ++ show supportedProtocolLo ++ " through " ++ show supportedProtocolHi+      ++ ", but got server version " ++ show serverVersion+      ++ ". Upgrading hegel-haskell or downgrading your hegel cli might help."+  ctrl <- controlChannel conn+  lock <- newMVar ()+  pure HegelClient+    { clientConnection = conn+    , clientControl = ctrl+    , clientLock = lock+    }+++-- ---------------------------------------------------------------------------+-- Test operations+-- ---------------------------------------------------------------------------++-- | Generates a value from a schema by sending a generate command to the+-- server. Raises 'DataExhausted' if the server signals StopTest.+generateFromSchema :: Term -> TestCase -> IO Term+generateFromSchema schema tc = do+  let ch = tcChannel tc+  let msg = TMap+        [ (TString "command", TString "generate")+        , (TString "schema", schema)+        ]+  result <- try (sendRequestAndWait ch msg) :: IO (Either RequestError Term)+  case result of+    Right val -> pure val+    Left (RequestError _ errType _)+      | errType == "StopTest" -> do+          writeIORef (tcTestAborted tc) True+          throwIO DataExhausted+    Left e -> throwIO e++-- | Rejects the current test case if the condition is 'False'.+assume :: TestCase -> Bool -> IO ()+assume _tc condition = unless condition $ throwIO AssumeRejected++-- | Fails the current property with a message and captured call stack.+failure :: HasCallStack => String -> IO a+failure message =+  withFrozenCallStack $+    throwIO+      AssertionFailure+        { assertionFailureMessage = message+        , assertionFailureCallStack = callStack+        }++-- | Asserts a property condition, reporting the call site on failure.+assert :: HasCallStack => Bool -> String -> IO ()+assert condition message = unless condition (withFrozenCallStack $ failure message)++-- | Records a message that will be printed on the final (failing) run.+note :: TestCase -> String -> IO ()+note tc message = when (tcIsFinal tc) $ hPutStrLn stderr message++-- | Sends a target command to guide the search engine toward higher values.+target :: TestCase -> Double -> String -> IO ()+target tc value label = do+  let ch = tcChannel tc+  let msg = TMap+        [ (TString "command", TString "target")+        , (TString "value", TDouble value)+        , (TString "label", TString (T.pack label))+        ]+  void $ sendRequestAndWait ch msg++-- | Starts a generation span for better shrinking.+startSpan :: Int -> TestCase -> IO ()+startSpan label tc = do+  aborted <- readIORef (tcTestAborted tc)+  unless aborted $ do+    let ch = tcChannel tc+    let msg = TMap+          [ (TString "command", TString "start_span")+          , (TString "label", TInt label)+          ]+    void $ sendRequestAndWait ch msg++-- | Ends the current generation span.+stopSpan :: Bool -> TestCase -> IO ()+stopSpan discard tc = do+  aborted <- readIORef (tcTestAborted tc)+  unless aborted $ do+    let ch = tcChannel tc+    let msg = TMap+          [ (TString "command", TString "stop_span")+          , (TString "discard", TBool discard)+          ]+    void $ sendRequestAndWait ch msg+++-- ---------------------------------------------------------------------------+-- Test case outcomes+-- ---------------------------------------------------------------------------++data TestOutcome+  = Valid+  | Invalid+  | DataWasExhausted+  | Interesting Text (Maybe SomeException)+    -- ^ origin text, and optionally the exception (on final run)++-- | Extracts a human-readable origin string from an exception.+extractOrigin :: SomeException -> Text+extractOrigin exn =+  case fromException exn of+    Just AssertionFailure {assertionFailureCallStack = stack} ->+      maybe fallback (T.pack . formatSrcLoc) (firstSrcLoc stack)+    Nothing -> fallback+  where+    fallback = T.pack (displayException exn)++firstSrcLoc :: CallStack -> Maybe SrcLoc+firstSrcLoc stack = snd <$> case getCallStack stack of+  [] -> Nothing+  frame : _ -> Just frame++formatSrcLoc :: SrcLoc -> String+formatSrcLoc SrcLoc {..} =+  srcLocFile ++ ":" ++ show srcLocStartLine ++ ":" ++ show srcLocStartCol++-- | Send mark_complete, swallowing StopTest errors.+markComplete :: Channel -> Text -> Term -> IO ()+markComplete ch status origin = do+  let msg = TMap+        [ (TString "command", TString "mark_complete")+        , (TString "status", TString status)+        , (TString "origin", origin)+        ]+  result <- try (sendRequestAndWait ch msg) :: IO (Either RequestError Term)+  case result of+    Left (RequestError _ errType _)+      | errType == "StopTest" -> pure ()+    Left e -> throwIO e+    Right _ -> pure ()++-- | Runs a single test case. Creates a 'TestCase', runs the user function,+-- catches exceptions, and sends mark_complete with the appropriate status+-- (VALID, INVALID, or INTERESTING). Handles StopTest on mark_complete.+runTestCase :: HegelClient -> Channel -> (TestCase -> IO ()) -> Bool -> IO ()+runTestCase _client ch testFn isFinal = do+  abortedRef <- newIORef False+  let tc = TestCase+        { tcChannel = ch+        , tcIsFinal = isFinal+        , tcTestAborted = abortedRef+        }+  outcome <- (testFn tc >> pure Valid) `catches`+    [ Handler $ \AssumeRejected -> pure Invalid+    , Handler $ \DataExhausted -> pure DataWasExhausted+    , Handler $ \(e :: SomeException) -> do+        let origin = extractOrigin e+        let ex = if isFinal then Just e else Nothing+        pure (Interesting origin ex)+    ]+  case outcome of+    DataWasExhausted -> pure ()+    Valid -> markComplete ch "VALID" TNull+    Invalid -> markComplete ch "INVALID" TNull+    Interesting originText _ -> markComplete ch "INTERESTING" (TString originText)+  closeChannel ch+  -- On final run, re-raise the interesting exception+  case outcome of+    Interesting _ (Just e) -> throwIO e+    _ -> pure ()+++-- ---------------------------------------------------------------------------+-- Full test lifecycle+-- ---------------------------------------------------------------------------++-- | Runs a full property test. Sends run_test on the control channel with+-- all settings fields, then processes test_case and test_done events.+-- Checks error, health_check_failure, flaky, and passed in results.+-- Replays interesting cases on the final run.+runTest :: HegelClient -> Settings -> (TestCase -> IO ()) -> IO ()+runTest client stgs testFn = do+  let conn = clientConnection client+  testChannel <- newChannel conn++  -- Send run_test command under the client lock+  withMVar (clientLock client) $ \_ -> do+    let seedValue = maybe TNull TInt (settingsSeed stgs)+    let databaseKeyValue = TNull+    let baseFields =+          [ (TString "command", TString "run_test")+          , (TString "test_cases", TInt (settingsTestCases stgs))+          , (TString "seed", seedValue)+          , (TString "channel_id", TInt (fromIntegral (channelId testChannel)))+          , (TString "database_key", databaseKeyValue)+          , (TString "derandomize", TBool (settingsDerandomize stgs))+          ]+    let databaseField = case settingsDatabase stgs of+          Unset          -> []+          Disabled       -> [(TString "database", TNull)]+          DatabasePath p -> [(TString "database", TString (T.pack p))]+    let suppressField = case settingsSuppressHealthCheck stgs of+          [] -> []+          checks ->+            [ ( TString "suppress_health_check"+              , TList (map (TString . healthCheckToString) checks)+              )+            ]+    let fields = baseFields ++ databaseField ++ suppressField+    void $ sendRequestAndWait (clientControl client) (TMap fields)++  -- Helper to receive and run a test case (used for replay)+  let receiveAndRunTestCase isFinal = do+        (msgId, msg) <- receiveRequest testChannel+        let pairs = extractMap msg+        let chId = extractInt (lookupCBOR "channel_id" pairs)+        sendResponseValue testChannel msgId TNull+        tcChan <- connectChannel conn (fromIntegral chId)+        runTestCase client tcChan testFn isFinal++  -- Event loop+  let receiveEvents = do+        (msgId, msg) <- receiveRequest testChannel+        let pairs = extractMap msg+        let event = extractText (lookupCBOR "event" pairs)+        case event of+          "test_case" -> do+            let chId = extractInt (lookupCBOR "channel_id" pairs)+            sendResponseValue testChannel msgId TNull+            tcChan <- connectChannel conn (fromIntegral chId)+            runTestCase client tcChan testFn False+            exited <- serverHasExited conn+            when exited $ fail serverCrashedMessage+            receiveEvents+          "test_done" -> do+            sendResponseValue testChannel msgId (TBool True)+            pure (extractMap (lookupCBOR "results" pairs))+          other -> do+            let errPayload = encodeTerm $ TMap+                  [ (TString "error", TString ("Unrecognised event " <> other))+                  , (TString "type", TString "InvalidMessage")+                  ]+            sendResponseRaw testChannel msgId errPayload+            receiveEvents++  results <- receiveEvents++  -- Check for server-side errors+  case lookupCBORMaybe "error" results of+    Just errorVal -> do+      let errorMsg = extractText errorVal+      fail ("Server error: " ++ T.unpack errorMsg)+    Nothing -> pure ()++  -- Check for health check failure+  case lookupCBORMaybe "health_check_failure" results of+    Just failureVal -> do+      let failureMsg = extractText failureVal+      fail ("Health check failure:\n" ++ T.unpack failureMsg)+    Nothing -> pure ()++  -- Check for flaky test detection+  case lookupCBORMaybe "flaky" results of+    Just flakyVal -> do+      let flakyMsg = extractText flakyVal+      fail ("Flaky test detected: " ++ T.unpack flakyMsg)+    Nothing -> pure ()++  -- Check passed flag+  let passed = case lookupCBORMaybe "passed" results of+        Just (TBool b) -> b+        _              -> True++  let nInteresting = extractInt (lookupCBOR "interesting_test_cases" results)++  if nInteresting == 0 && passed+    then pure ()+    else if nInteresting >= 1+      then do+        firstFailure <- try (receiveAndRunTestCase True)+        -- Drain any extra interesting cases quietly to keep the control+        -- channel in sync, but only surface the smallest final failure.+        replicateM_ (nInteresting - 1) (receiveAndRunTestCase False)+        case firstFailure of+          Left (e :: SomeException) -> throwIO e+          Right () -> unless passed $ throwIO (HegelTestFailure "Property test failed")+      else unless passed $ throwIO (HegelTestFailure "Property test failed")+++-- ---------------------------------------------------------------------------+-- CBOR helpers (local to this module)+-- ---------------------------------------------------------------------------++-- | Look up a key in a CBOR map (list of pairs), using a 'Text' key.+lookupCBOR :: Text -> [(Term, Term)] -> Term+lookupCBOR key pairs =+  case lookup (TString key) pairs of+    Just v  -> v+    Nothing -> error $ "Key not found in CBOR map: " ++ T.unpack key++-- | Look up a key in a CBOR map, returning 'Nothing' if absent.+lookupCBORMaybe :: Text -> [(Term, Term)] -> Maybe Term+lookupCBORMaybe key = lookup (TString key)

@@ -0,0 +1,43 @@+-- | Helpers for writing Hegel conformance test binaries.+--+-- Each conformance binary reads parameters from @argv[1]@ (JSON), runs a+-- property test that draws values and writes metrics, then exits.+module Hegel.Conformance+  ( getTestCases,+    writeMetrics,+    formatMetrics,+  )+where++import System.Environment (lookupEnv)+import System.IO (IOMode (..), hFlush, hPutStr, withFile)++-- | Read the number of test cases from the @CONFORMANCE_TEST_CASES@+-- environment variable. Defaults to 50.+getTestCases :: IO Int+getTestCases = do+  val <- lookupEnv "CONFORMANCE_TEST_CASES"+  pure $ maybe 50 read val++-- | Format a list of key-value pairs as a JSON object string (one line).+-- Values are already pre-formatted as JSON (e.g. numbers without quotes,+-- strings with quotes, @\"null\"@ for null).+formatMetrics :: [(String, String)] -> String+formatMetrics pairs =+  "{" ++ intercalate ", " (map fmt pairs) ++ "}\n"+  where+    fmt (k, v) = "\"" ++ k ++ "\": " ++ v+    intercalate _ [] = ""+    intercalate sep (x : xs) = x ++ concatMap (sep ++) xs++-- | Write metrics to the file specified by @CONFORMANCE_METRICS_FILE@.+-- If the variable is not set, does nothing.+writeMetrics :: [(String, String)] -> IO ()+writeMetrics pairs = do+  mPath <- lookupEnv "CONFORMANCE_METRICS_FILE"+  case mPath of+    Nothing -> pure ()+    Just path ->+      withFile path AppendMode $ \h -> do+        hPutStr h (formatMetrics pairs)+        hFlush h

@@ -0,0 +1,648 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE StrictData #-}++-- | Multiplexed connection and channel abstractions for Hegel.+--+-- This module implements a background-reader model: a dedicated thread reads+-- packets from the input stream and dispatches them to per-channel inboxes.+-- Channels use STM 'TQueue' for incoming messages.+--+-- A 'Connection' manages a pair of 'Handle's (one for reading, one for+-- writing) with multiplexed logical channels. A 'Channel' provides+-- request\/response messaging over a single logical channel.+module Hegel.Connection+  ( -- * Types+    Connection (..)+  , Channel (..)+  , InboxItem (..)+  , RequestError (..)+  , PendingRequest++    -- * Connection lifecycle+  , createConnection+  , closeConnection++    -- * Channel management+  , newChannel+  , connectChannel+  , closeChannel++    -- * Sending+  , sendPacket+  , sendRequest+  , sendRequestCBOR++    -- * Receiving+  , receiveResponse+  , receiveRequest+  , sendResponseValue++    -- * Handshake+  , sendHandshake++    -- * Result handling+  , resultOrError++    -- * Pending requests+  , request+  , pendingGet++    -- * Accessors+  , controlChannel+  , channelId+  , serverHasExited+  , setServerExited+  , isLive+  , sendRequestAndWait+  , sendResponseRaw+  , serverCrashedMessage+  ) where++import Codec.CBOR.Term (Term (..))+import Control.Concurrent.Async (Async, async, cancel)+import Control.Concurrent.MVar (MVar, newMVar, withMVar)+import Control.Concurrent.STM+  ( STM+  , TQueue+  , TVar+  , atomically+  , check+  , newTQueueIO+  , newTVarIO+  , orElse+  , readTQueue+  , readTVar+  , readTVarIO+  , registerDelay+  , writeTQueue+  , writeTVar+  , modifyTVar'+  )+import Control.Exception (Exception, SomeException, catch, throwIO)+import Control.Monad (unless, when)+import Data.Bits (shiftL, (.|.))+import Data.ByteString (ByteString)+import qualified Data.ByteString.Char8 as BS8+import Data.IORef (IORef, newIORef, readIORef, writeIORef)+import Data.Map.Strict (Map)+import qualified Data.Map.Strict as Map+import qualified Data.Text as T+import Data.Word (Word32)+import System.IO (Handle, hClose, hSetBinaryMode)++import Hegel.Protocol++-- ---------------------------------------------------------------------------+-- Constants+-- ---------------------------------------------------------------------------++-- | Handshake string sent by the client to initiate the protocol.+handshakeString :: ByteString+handshakeString = "hegel_handshake_start"++-- | Default timeout in microseconds for channel operations (30 seconds).+channelTimeoutMicros :: Int+channelTimeoutMicros = 30 * 1000000++-- | Message displayed when the server has crashed.+serverCrashedMessage :: String+serverCrashedMessage =+  "The hegel server process has exited unexpectedly. Check .hegel/server.log for details."++-- ---------------------------------------------------------------------------+-- Types+-- ---------------------------------------------------------------------------++-- | Sentinel value placed in a channel's inbox when the connection shuts down.+data InboxItem+  = Pkt Packet+  -- ^ A normal packet.+  | Shutdown+  -- ^ The connection has been closed.+  deriving (Show, Eq)++-- | Error response from the peer.+data RequestError = RequestError+  { reqErrorMessage :: String+  , reqErrorType :: String+  , reqErrorData :: [(Term, Term)]+  }+  deriving (Show)++instance Exception RequestError++-- | Multiplexed connection to a Hegel peer.+data Connection = Connection+  { connReadHandle :: Handle+  -- ^ Handle for reading packets.+  , connWriteHandle :: Handle+  -- ^ Handle for writing packets.+  , connNextChannelId :: TVar Int+  -- ^ Counter for allocating new channel IDs.+  , connChannels :: TVar (Map Word32 Channel)+  -- ^ Map from channel ID to live channel.+  , connRunning :: TVar Bool+  -- ^ Whether the connection is still active.+  , connServerExited :: TVar Bool+  -- ^ Whether the server process has exited unexpectedly.+  , connWriterLock :: MVar ()+  -- ^ Lock for serializing writes to the output handle.+  , connReaderThread :: Async ()+  -- ^ Background reader thread.+  , connDebug :: Bool+  -- ^ Whether debug logging is enabled.+  }++-- | Logical channel for request\/response messaging.+data Channel = Channel+  { chanId :: Word32+  -- ^ The channel ID.+  , chanConn :: Connection+  -- ^ The connection this channel belongs to.+  , chanInbox :: TQueue InboxItem+  -- ^ Inbox for incoming packets dispatched by the reader thread.+  , chanResponses :: TVar (Map Word32 ByteString)+  -- ^ Map from message ID to response payload (filled by 'processOneMessage').+  , chanRequests :: TQueue Packet+  -- ^ Queue of incoming request packets (filled by 'processOneMessage').+  , chanNextMessageId :: TVar Word32+  -- ^ Next message ID to use for outgoing requests.+  , chanClosed :: TVar Bool+  -- ^ Whether this channel has been closed.+  }++-- | A pending request handle that caches the decoded response.+data PendingRequest = PendingRequest+  { prChannel :: Channel+  , prMessageId :: Word32+  , prValue :: IORef (Maybe Term)+  }++-- ---------------------------------------------------------------------------+-- Connection lifecycle+-- ---------------------------------------------------------------------------++-- | Create a new connection using separate handles for reading and writing.+--+-- A control channel (channel 0) is automatically created and a background+-- reader thread is spawned. Both handles are set to binary mode.+createConnection :: Handle -> Handle -> Bool -> IO Connection+createConnection readH writeH debug = do+  hSetBinaryMode readH True+  hSetBinaryMode writeH True++  nextChanId <- newTVarIO 1+  channels <- newTVarIO Map.empty+  running <- newTVarIO True+  serverExited <- newTVarIO False+  writerLock <- newMVar ()++  -- Create a placeholder connection (reader thread filled in below)+  let mkConn reader = Connection+        { connReadHandle = readH+        , connWriteHandle = writeH+        , connNextChannelId = nextChanId+        , connChannels = channels+        , connRunning = running+        , connServerExited = serverExited+        , connWriterLock = writerLock+        , connReaderThread = reader+        , connDebug = debug+        }++  -- Create control channel (channel 0)+  controlInbox <- newTQueueIO+  controlResponses <- newTVarIO Map.empty+  controlRequests <- newTQueueIO+  controlNextMsgId <- newTVarIO 1+  controlClosed <- newTVarIO False++  -- We need the connection reference for the channel, but the connection+  -- needs the reader thread. Use a two-phase approach: create a dummy+  -- Async, build everything, then spawn the real reader.+  dummyAsync <- async (return ())++  let tempConn = mkConn dummyAsync++  let ctrl = Channel+        { chanId = 0+        , chanConn = tempConn+        , chanInbox = controlInbox+        , chanResponses = controlResponses+        , chanRequests = controlRequests+        , chanNextMessageId = controlNextMsgId+        , chanClosed = controlClosed+        }++  atomically $ writeTVar channels (Map.singleton 0 ctrl)++  -- Spawn background reader thread+  reader <- async (readerLoop tempConn)++  -- The connection returned uses the same TVars so the reader thread's+  -- reference via tempConn is equivalent. We return a version with the+  -- real Async handle for cleanup.+  let conn = mkConn reader++  -- Update the control channel to reference the real connection+  -- (shares the same TVars, so this is just for the Async handle)+  let ctrl' = ctrl { chanConn = conn }+  atomically $ writeTVar channels (Map.singleton 0 ctrl')++  return conn++-- | Close the connection and signal all live channels.+closeConnection :: Connection -> IO ()+closeConnection conn = do+  isRunning <- readTVarIO (connRunning conn)+  if not isRunning+    then return ()+    else do+      atomically $ writeTVar (connRunning conn) False+      catch (hClose (connReadHandle conn)) (\(_ :: SomeException) -> return ())+      -- Always attempt to close the write handle; if it is the same as+      -- the read handle, hClose will simply fail silently.+      catch (hClose (connWriteHandle conn)) (\(_ :: SomeException) -> return ())+      signalAllChannels conn+      cancel (connReaderThread conn)++-- ---------------------------------------------------------------------------+-- Background reader+-- ---------------------------------------------------------------------------++-- | Background reader thread function. Reads packets from the connection's+-- read handle and dispatches them to the appropriate channel's inbox.+-- Exits when the stream closes or an error occurs.+readerLoop :: Connection -> IO ()+readerLoop conn = do+  let loop = do+        isRunning <- readTVarIO (connRunning conn)+        when isRunning $ do+          pkt <- readPacket (connReadHandle conn)+          dispatchPacket conn pkt+          loop++  catch loop (\(_ :: SomeException) -> do+    atomically $ writeTVar (connServerExited conn) True)++  signalAllChannels conn++-- | Dispatch a single packet to the appropriate channel.+dispatchPacket :: Connection -> Packet -> IO ()+dispatchPacket conn pkt+  | packetPayload pkt == closeChannelPayload = return ()+  | otherwise = do+      mChan <- Map.lookup (packetChannelId pkt) <$> readTVarIO (connChannels conn)+      case mChan of+        Just ch -> atomically $ writeTQueue (chanInbox ch) (Pkt pkt)+        Nothing ->+          -- For non-reply messages to non-existent channels, send error back+          unless (packetIsReply pkt) $ do+            let errorMsg = "Message sent to non-existent channel "+                  ++ show (packetChannelId pkt)+                errorPayload = encodeTerm $+                  TMap [(TString "error", TString (T.pack errorMsg))]+            catch+              (sendPacket conn Packet+                { packetChannelId = packetChannelId pkt+                , packetMessageId = packetMessageId pkt+                , packetIsReply = True+                , packetPayload = errorPayload+                })+              (\(_ :: SomeException) -> return ())++-- | Push 'Shutdown' into all live channels' inboxes.+signalAllChannels :: Connection -> IO ()+signalAllChannels conn = do+  chans <- readTVarIO (connChannels conn)+  mapM_ (\ch -> atomically $ writeTQueue (chanInbox ch) Shutdown) (Map.elems chans)++-- ---------------------------------------------------------------------------+-- Channel management+-- ---------------------------------------------------------------------------++-- | Create a new logical channel on the connection.+--+-- Client channels use odd IDs: @(counter \<\< 1) | 1@.+newChannel :: Connection -> IO Channel+newChannel conn = do+  chanid <- atomically $ do+    counter <- readTVar (connNextChannelId conn)+    let cid = fromIntegral ((counter `shiftL` 1) .|. 1) :: Word32+    writeTVar (connNextChannelId conn) (counter + 1)+    return cid++  inbox <- newTQueueIO+  responses <- newTVarIO Map.empty+  requests <- newTQueueIO+  nextMsgId <- newTVarIO 1+  closed <- newTVarIO False++  let channel = Channel+        { chanId = chanid+        , chanConn = conn+        , chanInbox = inbox+        , chanResponses = responses+        , chanRequests = requests+        , chanNextMessageId = nextMsgId+        , chanClosed = closed+        }++  atomically $ modifyTVar' (connChannels conn) (Map.insert chanid channel)+  return channel++-- | Connect to a channel created by the peer (using the peer-assigned ID).+connectChannel :: Connection -> Word32 -> IO Channel+connectChannel conn cid = do+  exists <- atomically $ do+    chans <- readTVar (connChannels conn)+    return (Map.member cid chans)++  if exists+    then ioError $ userError $+      "Channel already connected as " ++ show cid ++ "."+    else do+      inbox <- newTQueueIO+      responses <- newTVarIO Map.empty+      requests <- newTQueueIO+      nextMsgId <- newTVarIO 1+      closed <- newTVarIO False++      let channel = Channel+            { chanId = cid+            , chanConn = conn+            , chanInbox = inbox+            , chanResponses = responses+            , chanRequests = requests+            , chanNextMessageId = nextMsgId+            , chanClosed = closed+            }++      atomically $ modifyTVar' (connChannels conn) (Map.insert cid channel)+      return channel++-- | Close a channel and notify the peer. Idempotent.+closeChannel :: Channel -> IO ()+closeChannel ch = do+  alreadyClosed <- readTVarIO (chanClosed ch)+  if alreadyClosed+    then return ()+    else do+      atomically $ writeTVar (chanClosed ch) True+      isRunning <- readTVarIO (connRunning (chanConn ch))+      when isRunning $+        sendPacket (chanConn ch) Packet+          { packetPayload = closeChannelPayload+          , packetMessageId = closeChannelMessageId+          , packetChannelId = chanId ch+          , packetIsReply = False+          }++-- ---------------------------------------------------------------------------+-- Sending+-- ---------------------------------------------------------------------------++-- | Send a packet on the connection, thread-safe via the writer lock.+sendPacket :: Connection -> Packet -> IO ()+sendPacket conn pkt =+  withMVar (connWriterLock conn) $ \() ->+    writePacket (connWriteHandle conn) pkt++-- | Send raw bytes as a request on a channel. Returns the message ID for+-- matching the response.+sendRequest :: Channel -> ByteString -> IO Word32+sendRequest ch payload = do+  msgId <- atomically $ do+    mid <- readTVar (chanNextMessageId ch)+    writeTVar (chanNextMessageId ch) (mid + 1)+    return mid+  sendPacket (chanConn ch) Packet+    { packetPayload = payload+    , packetChannelId = chanId ch+    , packetIsReply = False+    , packetMessageId = msgId+    }+  return msgId++-- | Send a CBOR-encoded request on a channel. Returns the message ID.+sendRequestCBOR :: Channel -> Term -> IO Word32+sendRequestCBOR ch term = sendRequest ch (encodeTerm term)++-- ---------------------------------------------------------------------------+-- Receiving+-- ---------------------------------------------------------------------------++-- | Pop an item from the channel's inbox, with a timeout in microseconds.+-- Returns 'Nothing' on timeout.+popInboxItem :: Channel -> Int -> IO InboxItem+popInboxItem ch timeoutUs = do+  timedOut <- registerDelay timeoutUs+  result <- atomically $+    (Just <$> readTQueue (chanInbox ch))+    `orElse`+    (do expired <- readTVar timedOut+        check expired+        return Nothing)+  case result of+    Just item -> return item+    Nothing -> do+      isClosed <- readTVarIO (chanClosed ch)+      if isClosed+        then ioError $ userError $ "Channel " ++ show (chanId ch) ++ " is closed"+        else do+          exited <- readTVarIO (connServerExited (chanConn ch))+          if exited+            then ioError $ userError serverCrashedMessage+            else ioError $ userError $+              "Timed out after " ++ show (timeoutUs `div` 1000000)+                ++ "s waiting for a message on channel " ++ show (chanId ch)++-- | Process one incoming message for a channel. Dispatches replies to the+-- responses map and requests to the requests queue.+processOneMessage :: Channel -> Int -> IO ()+processOneMessage ch timeoutUs = do+  item <- popInboxItem ch timeoutUs+  case item of+    Shutdown -> ioError $ userError "Connection closed"+    Pkt pkt ->+      if packetIsReply pkt+        then atomically $ modifyTVar' (chanResponses ch)+              (Map.insert (packetMessageId pkt) (packetPayload pkt))+        else atomically $ writeTQueue (chanRequests ch) pkt++-- | Wait for a raw response to a request with the given message ID.+receiveResponseRaw :: Channel -> Word32 -> Int -> IO ByteString+receiveResponseRaw ch msgId timeoutUs = do+  let waitLoop = do+        mResp <- atomically $ do+          resps <- readTVar (chanResponses ch)+          case Map.lookup msgId resps of+            Just payload -> do+              writeTVar (chanResponses ch) (Map.delete msgId resps)+              return (Just payload)+            Nothing -> return Nothing+        case mResp of+          Just payload -> return payload+          Nothing -> do+            processOneMessage ch timeoutUs+            waitLoop+  waitLoop++-- | Wait for and decode a response, extracting the result or raising+-- 'RequestError'.+receiveResponse :: Channel -> Word32 -> IO Term+receiveResponse ch msgId = do+  raw <- receiveResponseRaw ch msgId channelTimeoutMicros+  resultOrError (decodeTerm raw)++-- | Receive the next incoming request on a channel. Returns the message ID+-- and the decoded CBOR term.+receiveRequest :: Channel -> IO (Word32, Term)+receiveRequest ch = do+  let waitLoop = do+        mPkt <- atomically $ tryReadTQueue (chanRequests ch)+        case mPkt of+          Just pkt -> return (packetMessageId pkt, decodeTerm (packetPayload pkt))+          Nothing -> do+            processOneMessage ch channelTimeoutMicros+            waitLoop+  waitLoop+  where+    tryReadTQueue :: TQueue a -> STM (Maybe a)+    tryReadTQueue q = (Just <$> readTQueue q) `orElse` return Nothing++-- | Send a success response with a value wrapped as @{\"result\": value}@.+sendResponseValue :: Channel -> Word32 -> Term -> IO ()+sendResponseValue ch msgId value = do+  let payload = encodeTerm $ TMap [(TString "result", value)]+  sendPacket (chanConn ch) Packet+    { packetPayload = payload+    , packetChannelId = chanId ch+    , packetIsReply = True+    , packetMessageId = msgId+    }++-- ---------------------------------------------------------------------------+-- Result handling+-- ---------------------------------------------------------------------------++-- | Extract the @\"result\"@ field from a CBOR map, or throw 'RequestError'+-- if an @\"error\"@ field is present.+resultOrError :: Term -> IO Term+resultOrError body = do+  let pairs = extractMap body+      findText key = case lookup (TString key) pairs of+        Just v -> T.unpack (extractText v)+        Nothing -> ""+  case lookup (TString "error") pairs of+    Just _ -> do+      let msg = findText "error"+          errorType = findText "type"+          dat = filter (\(k, _) -> k /= TString "error" && k /= TString "type") pairs+      throwIO $ RequestError msg errorType dat+    Nothing ->+      case lookup (TString "result") pairs of+        Just v -> return v+        Nothing -> ioError $ userError "Response has neither 'result' nor 'error'"++-- ---------------------------------------------------------------------------+-- Pending requests+-- ---------------------------------------------------------------------------++-- | Send a CBOR request and return a 'PendingRequest' handle.+request :: Channel -> Term -> IO PendingRequest+request ch term = do+  msgId <- sendRequestCBOR ch term+  ref <- newIORef Nothing+  return PendingRequest+    { prChannel = ch+    , prMessageId = msgId+    , prValue = ref+    }++-- | Block until the response arrives and return the result.+--+-- Caches the response so subsequent calls return the same value or raise+-- the same error.+pendingGet :: PendingRequest -> IO Term+pendingGet pr = do+  cached <- readIORef (prValue pr)+  case cached of+    Just v -> resultOrError v+    Nothing -> do+      raw <- receiveResponseRaw (prChannel pr) (prMessageId pr) channelTimeoutMicros+      let v = decodeTerm raw+      writeIORef (prValue pr) (Just v)+      resultOrError v++-- ---------------------------------------------------------------------------+-- Handshake+-- ---------------------------------------------------------------------------++-- | Initiate the handshake as a client. Returns the server protocol version+-- string (e.g. @\"0.1\"@).+sendHandshake :: Connection -> IO String+sendHandshake conn = do+  -- Get control channel (channel 0)+  mCh <- atomically $ do+    chans <- readTVar (connChannels conn)+    return (Map.lookup 0 chans)+  ch <- case mCh of+    Just c -> return c+    Nothing -> ioError $ userError "Internal error: no control channel"++  msgId <- sendRequest ch handshakeString+  raw <- receiveResponseRaw ch msgId channelTimeoutMicros++  let response = BS8.unpack raw+      prefix = "Hegel/"+  if take 6 response /= prefix+    then ioError $ userError $ "Bad handshake response: " ++ show response+    else return (drop 6 response)++-- ---------------------------------------------------------------------------+-- Additional accessors+-- ---------------------------------------------------------------------------++-- | Get the control channel (channel 0).+controlChannel :: Connection -> IO Channel+controlChannel conn = do+  mCh <- atomically $ do+    chans <- readTVar (connChannels conn)+    return (Map.lookup 0 chans)+  case mCh of+    Just c -> return c+    Nothing -> ioError $ userError "Internal error: no control channel"++-- | Get the channel ID.+channelId :: Channel -> Word32+channelId = chanId++-- | Check if the server process has exited.+serverHasExited :: Connection -> IO Bool+serverHasExited conn = readTVarIO (connServerExited conn)++-- | Set the server-exited flag.+setServerExited :: Connection -> IO ()+setServerExited conn = atomically $ writeTVar (connServerExited conn) True++-- | Check if the connection is still active.+isLive :: Connection -> IO Bool+isLive conn = readTVarIO (connRunning conn)++-- | Send a CBOR request and wait for the decoded response (convenience).+sendRequestAndWait :: Channel -> Term -> IO Term+sendRequestAndWait ch msg = do+  msgId <- sendRequestCBOR ch msg+  receiveResponse ch msgId++-- | Send raw bytes as a reply.+sendResponseRaw :: Channel -> Word32 -> ByteString -> IO ()+sendResponseRaw ch msgId payload =+  sendPacket (chanConn ch) Packet+    { packetChannelId = chanId ch+    , packetMessageId = msgId+    , packetIsReply = True+    , packetPayload = payload+    }

@@ -0,0 +1,385 @@+{-# LANGUAGE GADTs #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}++-- | Core generator GADT and evaluation machinery.+--+-- Generators produce typed Haskell values by communicating with the Hegel+-- server over CBOR. The 'Generator' type is a GADT with six constructors+-- reflecting different generation strategies:+--+-- * 'Basic' holds a raw CBOR schema and a transform; the server generates the+--   value in one round-trip.+-- * 'Mapped' wraps a source generator and a transform function.+-- * 'FlatMapped' wraps a source and a function returning a generator.+-- * 'Filtered' wraps a source and a predicate (up to 'maxFilterAttempts' retries).+-- * 'CompositeList' uses the collection protocol for non-basic list elements.+-- * 'Composite' wraps a generation function inside a labelled span.+module Hegel.Generator+  ( -- * Generator type+    Generator (..)++    -- * Evaluation+  , draw++    -- * Combinators+  , gmap+  , flatMap+  , gfilter++    -- * Introspection+  , isBasic+  , asBasic++    -- * Span helpers+  , group+  , discardableGroup++    -- * Collection protocol+  , Collection (..)+  , newCollection+  , collectionMore+  , collectionReject++    -- * Span label constants+  , labelList+  , labelListElement+  , labelSet+  , labelSetElement+  , labelMap+  , labelMapEntry+  , labelTuple+  , labelOneOf+  , labelOptional+  , labelFixedDict+  , labelFlatMap+  , labelFilter+  , labelMapped+  , labelSampledFrom+  , labelEnumVariant++    -- * Constants+  , maxFilterAttempts+  ) where++import Codec.CBOR.Term (Term (..))+import Control.Exception (SomeException, catch, throwIO)+import Control.Monad (unless)+import Data.IORef++import Hegel.Client+  ( DataExhausted (..)+  , TestCase (..)+  , assume+  , generateFromSchema+  , startSpan+  , stopSpan+  )+import Hegel.Connection (RequestError (..), sendRequestAndWait)++-- ----------------------------------------------------------------------------+-- Span label constants+-- ----------------------------------------------------------------------------++-- | Span label for list generation.+labelList :: Int+labelList = 1++-- | Span label for individual list elements.+labelListElement :: Int+labelListElement = 2++-- | Span label for set generation.+labelSet :: Int+labelSet = 3++-- | Span label for individual set elements.+labelSetElement :: Int+labelSetElement = 4++-- | Span label for map (dictionary) generation.+labelMap :: Int+labelMap = 5++-- | Span label for individual map entries.+labelMapEntry :: Int+labelMapEntry = 6++-- | Span label for tuple generation.+labelTuple :: Int+labelTuple = 7++-- | Span label for one-of dispatch.+labelOneOf :: Int+labelOneOf = 8++-- | Span label for optional generation.+labelOptional :: Int+labelOptional = 9++-- | Span label for fixed-dict generation.+labelFixedDict :: Int+labelFixedDict = 10++-- | Span label for flat-map generation.+labelFlatMap :: Int+labelFlatMap = 11++-- | Span label for filter generation.+labelFilter :: Int+labelFilter = 12++-- | Span label for mapped generation.+labelMapped :: Int+labelMapped = 13++-- | Span label for sampled-from generation.+labelSampledFrom :: Int+labelSampledFrom = 14++-- | Span label for enum variant generation.+labelEnumVariant :: Int+labelEnumVariant = 15++-- | Maximum number of filter attempts before calling @assume False@.+maxFilterAttempts :: Int+maxFilterAttempts = 3++-- ----------------------------------------------------------------------------+-- Generator GADT+-- ----------------------------------------------------------------------------++-- | A generator that produces values of type @a@.+--+-- The GADT constructors capture different generation strategies. 'Basic'+-- generators carry a CBOR schema sent to the server; the server returns a raw+-- 'Term' that is decoded by the transform. Other constructors compose+-- generators with client-side logic.+data Generator a where+  -- | A server-side generator with a CBOR schema and a client-side transform.+  Basic :: Term -> (Term -> a) -> Generator a+  -- | A mapped generator: apply @f@ to the result of the source.+  Mapped :: Generator b -> (b -> a) -> Generator a+  -- | A dependent generator: generate from source, then use the result to+  -- pick a second generator.+  FlatMapped :: Generator b -> (b -> Generator a) -> Generator a+  -- | A filtered generator: retry the source until the predicate holds.+  Filtered :: Generator a -> (a -> Bool) -> Generator a+  -- | A composite list generator using the collection protocol.+  CompositeList :: Generator a -> Int -> Maybe Int -> Generator [a]+  -- | A composite generator that runs an arbitrary IO action inside a+  -- labelled span.+  Composite :: Int -> (TestCase -> IO a) -> Generator a++instance Functor Generator where+  fmap f (Basic s t) = Basic s (f . t)  -- preserves schema+  fmap f other       = Mapped other f++-- ----------------------------------------------------------------------------+-- Span helpers+-- ----------------------------------------------------------------------------++-- | Run an IO action inside a span with the given label.+-- The span is stopped with @discard=False@ regardless of whether the action+-- throws.+group :: Int -> TestCase -> IO a -> IO a+group label tc action = do+  startSpan label tc+  result <- action `catch` \(e :: SomeException) -> do+    stopSpan False tc+    throwIO e+  stopSpan False tc+  return result++-- | Run an IO action inside a span with the given label. If the action+-- throws, the span is stopped with @discard=True@; otherwise @discard=False@.+discardableGroup :: Int -> TestCase -> IO a -> IO a+discardableGroup label tc action = do+  startSpan label tc+  result <- action `catch` \(e :: SomeException) -> do+    stopSpan True tc+    throwIO e+  stopSpan False tc+  return result++-- ----------------------------------------------------------------------------+-- Collection protocol+-- ----------------------------------------------------------------------------++-- | A server-side collection handle for generating variable-length sequences.+--+-- Collections communicate with the server to decide when to stop generating+-- elements. The 'collFinished' flag short-circuits subsequent 'collectionMore'+-- calls once the server signals completion.+data Collection = Collection+  { collFinished   :: !(IORef Bool)+  , collServerName :: !(IORef (Maybe Term))+  , collMinSize    :: !Int+  , collMaxSize    :: !(Maybe Int)+  }++-- | Create a new collection handle.+newCollection :: Int -> Maybe Int -> TestCase -> IO Collection+newCollection minSize maxSize _tc = do+  finished   <- newIORef False+  serverName <- newIORef Nothing+  return Collection+    { collFinished   = finished+    , collServerName = serverName+    , collMinSize    = minSize+    , collMaxSize    = maxSize+    }++-- | Send a command on the test case's data channel. Handles StopTest.+sendCommand :: TestCase -> Term -> IO Term+sendCommand tc msg = do+  aborted <- readIORef (tcTestAborted tc)+  if aborted+    then throwIO DataExhausted+    else sendRequestAndWait (tcChannel tc) msg+           `catch` \(e :: RequestError) ->+             if reqErrorType e == "StopTest"+               then do+                 writeIORef (tcTestAborted tc) True+                 throwIO DataExhausted+               else throwIO e++-- | Lazily initialise the server-side collection and return its handle.+getServerName :: Collection -> TestCase -> IO Term+getServerName coll tc = do+  mName <- readIORef (collServerName coll)+  case mName of+    Just name -> return name+    Nothing -> do+      let maxSizeVal = maybe TNull TInt (collMaxSize coll)+      let cmd = TMap+            [ (TString "command",  TString "new_collection")+            , (TString "min_size", TInt (collMinSize coll))+            , (TString "max_size", maxSizeVal)+            ]+      result <- sendCommand tc cmd+      writeIORef (collServerName coll) (Just result)+      return result++-- | Query the server for whether more elements should be generated.+-- Once this returns 'False', subsequent calls return 'False' immediately.+collectionMore :: Collection -> TestCase -> IO Bool+collectionMore coll tc = do+  done <- readIORef (collFinished coll)+  if done+    then return False+    else do+      serverName <- getServerName coll tc+      let cmd = TMap+            [ (TString "command",    TString "collection_more")+            , (TString "collection", serverName)+            ]+      result <- sendCommand tc cmd+      let more = case result of+            TBool b -> b+            _       -> error "collectionMore: expected boolean from server"+      unless more $ writeIORef (collFinished coll) True+      return more++-- | Reject the last element of the collection. No-op if already finished.+collectionReject :: Collection -> TestCase -> IO ()+collectionReject coll tc = do+  done <- readIORef (collFinished coll)+  if done+    then return ()+    else do+      serverName <- getServerName coll tc+      let cmd = TMap+            [ (TString "command",    TString "collection_reject")+            , (TString "collection", serverName)+            ]+      _ <- sendCommand tc cmd+      return ()++-- ----------------------------------------------------------------------------+-- Draw (evaluation)+-- ----------------------------------------------------------------------------++-- | Produce a typed value from a generator using the given test case.+draw :: TestCase -> Generator a -> IO a+draw tc gen = case gen of+  Basic schema transform -> do+    raw <- generateFromSchema schema tc+    return (transform raw)++  Mapped source f ->+    group labelMapped tc $ do+      v <- draw tc source+      return (f v)++  FlatMapped source f ->+    discardableGroup labelFlatMap tc $ do+      v <- draw tc source+      draw tc (f v)++  Filtered source predicate ->+    let attempt i+          | i > maxFilterAttempts = do { assume tc False; error "unreachable" }+          | otherwise = do+              startSpan labelFilter tc+              v <- draw tc source+              if predicate v+                then do+                  stopSpan False tc+                  return v+                else do+                  stopSpan True tc+                  attempt (i + 1)+    in attempt 1++  CompositeList elements minSize maxSize ->+    group labelList tc $ do+      coll <- newCollection minSize maxSize tc+      let collect acc = do+            more <- collectionMore coll tc+            if more+              then do+                v <- draw tc elements+                collect (v : acc)+              else return (reverse acc)+      collect []++  Composite label generateFn ->+    group label tc (generateFn tc)++-- ----------------------------------------------------------------------------+-- Combinator functions+-- ----------------------------------------------------------------------------++-- | Map a function over a generator's output.+--+-- When the generator is 'Basic', the schema is preserved and transforms are+-- composed. Otherwise a 'Mapped' wrapper is created.+gmap :: (a -> b) -> Generator a -> Generator b+gmap f (Basic schema transform) = Basic schema (f . transform)+gmap f other                    = Mapped other f++-- | Create a dependent generator. The function receives the generated value+-- and returns a new generator whose output is the final result.+flatMap :: (a -> Generator b) -> Generator a -> Generator b+flatMap f gen = FlatMapped gen f++-- | Filter a generator's output with a predicate. Retries up to+-- 'maxFilterAttempts' times; if all attempts fail, @assume False@ is called.+gfilter :: (a -> Bool) -> Generator a -> Generator a+gfilter predicate gen = Filtered gen predicate++-- ----------------------------------------------------------------------------+-- Introspection+-- ----------------------------------------------------------------------------++-- | Returns 'True' if the generator is a 'Basic' generator.+isBasic :: Generator a -> Bool+isBasic (Basic _ _) = True+isBasic _           = False++-- | Returns the schema and transform of a 'Basic' generator, or 'Nothing'.+asBasic :: Generator a -> Maybe (Term, Term -> a)+asBasic (Basic schema transform) = Just (schema, transform)+asBasic _                        = Nothing

@@ -0,0 +1,88 @@+{-# LANGUAGE OverloadedStrings #-}++-- | Collection generators: lists and hashmaps.+--+-- These generators handle variable-length collections. When all element+-- generators are 'Basic', a single schema is sent to the server for efficient+-- generation. When elements are non-basic (e.g. filtered or flat-mapped), the+-- collection protocol is used to generate elements one at a time.+module Hegel.Generator.Collections+  ( lists+  , hashmaps+  ) where++import Codec.CBOR.Term (Term (..))+import Data.Maybe (catMaybes)++import Hegel.Generator (Generator (..), asBasic)+import Hegel.Generator.Range (RangeOpts, validateSizeBounds)++-- ----------------------------------------------------------------------------+-- Lists+-- ----------------------------------------------------------------------------++-- | Generator for lists of elements.+--+-- Two code paths:+--+-- 1. If the element generator is 'Basic': sends a @list@ schema to the server+--    and lets it generate the entire list in one round-trip. The element+--    transform is lifted to apply to every item.+--+-- 2. If the element generator is non-basic: uses 'CompositeList' with the+--    collection protocol to generate elements one at a time.+lists :: Generator a -> RangeOpts Int -> Generator [a]+lists elements opts =+  let (ms, maxSize) = validateSizeBounds "lists" opts+  in+  case asBasic elements of+    Just (elemSchema, elemTransform) ->+      let pairs = catMaybes+            [ Just (TString "type",     TString "list")+            , Just (TString "elements", elemSchema)+            , Just (TString "min_size", TInt ms)+            , fmap (\mx -> (TString "max_size", TInt mx)) maxSize+            ]+          listTransform raw = case raw of+            TList items -> map elemTransform items+            _           -> error "lists: expected array from server"+      in Basic (TMap pairs) listTransform++    Nothing ->+      CompositeList elements ms maxSize++-- ----------------------------------------------------------------------------+-- Hashmaps+-- ----------------------------------------------------------------------------++-- | Generator for dictionaries (hash maps) as lists of key-value pairs.+--+-- Both the key and value generators must be 'Basic'. The server returns the+-- dict as a list of @[key, value]@ pairs, which are transformed to Haskell+-- tuples.+--+-- Schema: @{\"type\": \"dict\", \"keys\": kSchema, \"values\": vSchema,+-- \"min_size\": N, \"max_size\"?: N}@+hashmaps :: Generator k -> Generator v -> RangeOpts Int -> Generator [(k, v)]+hashmaps keys values opts =+  let (ms, maxSize) = validateSizeBounds "hashmaps" opts in+  let (keySchema, keyTransform) = case asBasic keys of+        Just (s, t) -> (s, t)+        Nothing     -> error "hashmaps: keys generator must be a Basic generator"+      (valSchema, valTransform) = case asBasic values of+        Just (s, t) -> (s, t)+        Nothing     -> error "hashmaps: values generator must be a Basic generator"+      pairs = catMaybes+        [ Just (TString "type",     TString "dict")+        , Just (TString "keys",     keySchema)+        , Just (TString "values",   valSchema)+        , Just (TString "min_size", TInt ms)+        , fmap (\mx -> (TString "max_size", TInt mx)) maxSize+        ]+      transform raw = case raw of+        TList kvPairs -> map transformPair kvPairs+        _             -> error "hashmaps: expected array from server"+      transformPair pair = case pair of+        TList [k, v] -> (keyTransform k, valTransform v)+        _            -> error "hashmaps: expected [k, v] pair from server"+  in Basic (TMap pairs) transform

@@ -0,0 +1,231 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}++-- | Combinator generators: sampling, alternation, optionality, IP addresses,+-- and tuples.+--+-- These generators compose primitive and collection generators into richer+-- generation strategies. When all constituent generators are 'Basic', a single+-- compound schema is sent to the server. When any generator is non-basic, a+-- 'Composite' wrapper is used with client-side orchestration.+module Hegel.Generator.Combinators+  ( sampledFrom+  , oneOf+  , optional+  , ipAddresses+  , tuples2+  , tuples3+  , tuples4+  ) where++import Codec.CBOR.Term (Term (..))+import Data.Array (listArray, (!))+import Data.Default (def)+import Data.Maybe (catMaybes, isJust)+import Data.Text (Text)++import Hegel.Client (TestCase, generateFromSchema)+import Hegel.Generator+  ( Generator (..)+  , asBasic+  , draw+  , labelOneOf+  , labelTuple+  )+import Hegel.Generator.Primitives+  ( RangeOpts (..)+  , integers+  , ipv4Addresses+  , ipv6Addresses+  , just+  )++-- ----------------------------------------------------------------------------+-- CBOR extraction helper+-- ----------------------------------------------------------------------------++-- | 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++-- ----------------------------------------------------------------------------+-- sampledFrom+-- ----------------------------------------------------------------------------++-- | Generator that samples uniformly from a non-empty list of values.+--+-- Implemented as an integer index generator: picks an index in @[0, n-1]@ and+-- returns the corresponding element from an array.+sampledFrom :: [a] -> Generator a+sampledFrom [] = error "sampledFrom: requires at least one element"+sampledFrom options =+  let n   = length options+      arr = listArray (0, n - 1) options+  in fmap (arr !) (integers def+      { rangeMin = Just 0+      , rangeMax = Just (n - 1)+      })++-- ----------------------------------------------------------------------------+-- oneOf+-- ----------------------------------------------------------------------------++-- | Generator that picks from one of the given generators.+--+-- Two code paths:+--+-- 1. All generators are 'Basic': uses a tagged-tuple dispatch schema.+--    Each alternative is wrapped as @{\"type\": \"tuple\", \"elements\":+--    [{\"const\": tag}, schema]}@. The server returns @[tag, value]@ and the+--    client dispatches to the correct transform.+--+-- 2. Any generator is non-basic: generates an index inside a 'labelOneOf'+--    span, then delegates to the selected generator.+oneOf :: [Generator a] -> Generator a+oneOf [] = error "oneOf: requires at least one generator"+oneOf generators =+  let basics   = map asBasic generators+      allBasic = all isJust basics+  in+  if not allBasic+    then+      -- Composite path: generate index, then delegate+      let gens = listArray (0, n - 1) generators+      in Composite labelOneOf $ \tc -> do+           idx <- drawIndex n tc+           draw tc (gens ! idx)+    else+      -- Tagged-tuple path+      let justBasics = catMaybes basics+          taggedSchemas = zipWith mkTaggedSchema [0..] (map fst justBasics)+          transforms    = listArray (0, length justBasics - 1) (map snd justBasics)+          dispatch raw = case raw of+            TList [tag, value] ->+              let idx = extractInt tag+              in (transforms ! idx) value+            _ -> error "oneOf: expected [tag, value] tuple from server"+      in Basic+           (TMap [(TString "one_of", TList taggedSchemas)])+           dispatch+  where+    n = length generators++    drawIndex :: Int -> TestCase -> IO Int+    drawIndex count tc = do+      let schema = TMap+            [ (TString "type",      TString "integer")+            , (TString "min_value", TInt 0)+            , (TString "max_value", TInt (count - 1))+            ]+      raw <- generateFromSchema schema tc+      return (extractInt raw)++    mkTaggedSchema :: Int -> Term -> Term+    mkTaggedSchema i elemSchema = TMap+      [ (TString "type",     TString "tuple")+      , (TString "elements", TList+          [ TMap [(TString "const", TInt i)]+          , elemSchema+          ])+      ]++-- ----------------------------------------------------------------------------+-- optional+-- ----------------------------------------------------------------------------++-- | Generator that produces either 'Nothing' or @'Just' value@.+--+-- Equivalent to @oneOf [just Nothing, fmap Just gen]@.+optional :: Generator a -> Generator (Maybe a)+optional gen = oneOf [just Nothing, fmap Just gen]++-- ----------------------------------------------------------------------------+-- IP addresses+-- ----------------------------------------------------------------------------++-- | Generator for IP address strings.+--+-- * @Nothing@: generates either IPv4 or IPv6 addresses.+-- * @Just 4@: generates IPv4 addresses only.+-- * @Just 6@: generates IPv6 addresses only.+ipAddresses :: Maybe Int -> Generator Text+ipAddresses Nothing  = oneOf [ipv4Addresses, ipv6Addresses]+ipAddresses (Just 4) = ipv4Addresses+ipAddresses (Just 6) = ipv6Addresses+ipAddresses (Just v) = error $ "ipAddresses: invalid version " ++ show v++-- ----------------------------------------------------------------------------+-- Tuples+-- ----------------------------------------------------------------------------++-- | Generator for 2-element tuples.+--+-- When both elements are 'Basic', a single @tuple@ schema is sent.+-- Otherwise, elements are generated separately inside a 'labelTuple' span.+tuples2 :: Generator a -> Generator b -> Generator (a, b)+tuples2 g1 g2 =+  case (asBasic g1, asBasic g2) of+    (Just (s1, t1), Just (s2, t2)) ->+      let schema = TMap+            [ (TString "type",     TString "tuple")+            , (TString "elements", TList [s1, s2])+            ]+          transform raw = case raw of+            TList [v1, v2] -> (t1 v1, t2 v2)+            _ -> error "tuples2: expected 2-element array from server"+      in Basic schema transform+    _ ->+      Composite labelTuple $ \tc -> do+        a <- draw tc g1+        b <- draw tc g2+        return (a, b)++-- | Generator for 3-element tuples.+--+-- When all elements are 'Basic', a single @tuple@ schema is sent.+-- Otherwise, elements are generated separately inside a 'labelTuple' span.+tuples3 :: Generator a -> Generator b -> Generator c -> Generator (a, b, c)+tuples3 g1 g2 g3 =+  case (asBasic g1, asBasic g2, asBasic g3) of+    (Just (s1, t1), Just (s2, t2), Just (s3, t3)) ->+      let schema = TMap+            [ (TString "type",     TString "tuple")+            , (TString "elements", TList [s1, s2, s3])+            ]+          transform raw = case raw of+            TList [v1, v2, v3] -> (t1 v1, t2 v2, t3 v3)+            _ -> error "tuples3: expected 3-element array from server"+      in Basic schema transform+    _ ->+      Composite labelTuple $ \tc -> do+        a <- draw tc g1+        b <- draw tc g2+        c <- draw tc g3+        return (a, b, c)++-- | Generator for 4-element tuples.+--+-- When all elements are 'Basic', a single @tuple@ schema is sent.+-- Otherwise, elements are generated separately inside a 'labelTuple' span.+tuples4 :: Generator a -> Generator b -> Generator c -> Generator d+        -> Generator (a, b, c, d)+tuples4 g1 g2 g3 g4 =+  case (asBasic g1, asBasic g2, asBasic g3, asBasic g4) of+    (Just (s1, t1), Just (s2, t2), Just (s3, t3), Just (s4, t4)) ->+      let schema = TMap+            [ (TString "type",     TString "tuple")+            , (TString "elements", TList [s1, s2, s3, s4])+            ]+          transform raw = case raw of+            TList [v1, v2, v3, v4] -> (t1 v1, t2 v2, t3 v3, t4 v4)+            _ -> error "tuples4: expected 4-element array from server"+      in Basic schema transform+    _ ->+      Composite labelTuple $ \tc -> do+        a <- draw tc g1+        b <- draw tc g2+        c <- draw tc g3+        d <- draw tc g4+        return (a, b, c, d)

@@ -0,0 +1,303 @@+{-# 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

@@ -0,0 +1,55 @@+-- | Shared range option types and validation helpers.+module Hegel.Generator.Range+  ( RangeOpts (..)+  , defaultRangeOpts+  , validateSizeBounds+  ) where++import Data.Default (Default (def))+import Data.Maybe (fromMaybe)++-- | Configuration for lower and upper bounds used by range-limited generators.+--+-- Use 'def' for the default unbounded case, or update specific fields:+--+-- @+-- integers def { rangeMin = Just 0, rangeMax = Just 100 }+-- text def { rangeMin = Just 1, rangeMax = Just 10 }+-- @+--+-- Collection-like generators interpret these fields as @min_size@ and+-- @max_size@ bounds.+data RangeOpts a = RangeOpts+  { rangeMin :: !(Maybe a)+  -- ^ Inclusive lower bound when present.+  , rangeMax :: !(Maybe a)+  -- ^ Inclusive upper bound when present.+  } deriving (Eq, Show)++instance Default (RangeOpts a) where+  def = RangeOpts+    { rangeMin = Nothing+    , rangeMax = Nothing+    }++-- | Convenience alias for 'def'.+defaultRangeOpts :: RangeOpts a+defaultRangeOpts = def++-- | Validate non-negative size bounds and return the normalized min/max pair.+validateSizeBounds :: String -> RangeOpts Int -> (Int, Maybe Int)+validateSizeBounds label RangeOpts {rangeMin = minSize, rangeMax = maxSize} =+  (if minSize' < 0+     then error $ label ++ ": min_size=" ++ show minSize' ++ " must be non-negative"+     else ())+  `seq`+  (case maxSize of+     Just mx | mx < 0 ->+       error $ label ++ ": max_size=" ++ show mx ++ " must be non-negative"+     Just mx | minSize' > mx ->+       error $ label ++ ": max_size=" ++ show mx ++ " < min_size=" ++ show minSize'+     _ -> ())+  `seq`+  (minSize', maxSize)+  where+    minSize' = fromMaybe 0 minSize

@@ -0,0 +1,357 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE StrictData #-}++-- | Wire protocol for Hegel.+--+-- This module defines the binary packet format used for communication between+-- the Hegel client and the Hegel server. Messages are serialized as packets+-- with a 20-byte header, a CBOR-encoded payload, and a terminator byte.+--+-- The header consists of 5 big-endian unsigned 32-bit integers:+--+--   * Magic number (0x4845474C, \"HEGL\")+--   * CRC32 checksum+--   * Channel ID+--   * Message ID (high bit = reply flag)+--   * Payload length+module Hegel.Protocol+  ( -- * Packet type+    Packet (..)++    -- * Constants+  , magic+  , headerSize+  , terminator+  , replyBit+  , closeChannelMessageId+  , closeChannelPayload++    -- * Packet I\/O+  , readPacket+  , writePacket++    -- * CRC32+  , computeCRC32+  , computeCRC32Parts++    -- * CBOR helpers+  , extractInt+  , extractFloat+  , extractBool+  , extractText+  , extractBytes+  , extractList+  , extractMap+  , encodeTerm+  , decodeTerm+  ) where++import Codec.CBOR.Read (deserialiseFromBytes)+import Codec.CBOR.Term (Term (..))+import qualified Codec.CBOR.Term as CBOR+import qualified Codec.CBOR.Write as CBORWrite+import Control.Monad (when)+import Data.Bits ((.&.), (.|.), shiftL, shiftR, testBit, xor)+import Data.ByteString (ByteString)+import qualified Data.ByteString as BS+import qualified Data.ByteString.Internal as BSInternal+import qualified Data.ByteString.Lazy as LBS+import Data.Digest.CRC32 (crc32, crc32Update)+import Data.Text (Text)+import Data.Word (Word32, Word8)+import Foreign.Ptr (Ptr)+import Foreign.Storable (pokeByteOff)+import System.IO (Handle, hFlush)++-- ---------------------------------------------------------------------------+-- Constants+-- ---------------------------------------------------------------------------++-- | Magic number identifying Hegel packets (\"HEGL\" in hex).+magic :: Word32+magic = 0x4845474C++-- | Size of the packet header in bytes (5 big-endian uint32 fields).+headerSize :: Int+headerSize = 20++-- | Terminator byte appended after the payload.+terminator :: Word8+terminator = 0x0A++-- | Bit flag indicating a reply message. When set in the message ID field,+-- the message is a response to a previous request.+replyBit :: Word32+replyBit = 1 `shiftL` 31++-- | Special message ID used when closing a channel.+closeChannelMessageId :: Word32+closeChannelMessageId = (1 `shiftL` 31) - 1++-- | Special payload byte sent when closing a channel. Chosen to be invalid+-- CBOR per RFC 8949 (reserved tag byte 0xFE).+closeChannelPayload :: ByteString+closeChannelPayload = BS.singleton 0xFE++-- ---------------------------------------------------------------------------+-- Packet type+-- ---------------------------------------------------------------------------++-- | A single message in the wire protocol.+data Packet = Packet+  { packetChannelId :: Word32+  -- ^ The logical channel this packet belongs to.+  , packetMessageId :: Word32+  -- ^ Identifier for request\/response correlation (without reply bit).+  , packetIsReply :: Bool+  -- ^ Whether this is a reply to a previous request.+  , packetPayload :: ByteString+  -- ^ The raw payload bytes (typically CBOR-encoded).+  }+  deriving (Show, Eq)++-- ---------------------------------------------------------------------------+-- Byte packing helpers+-- ---------------------------------------------------------------------------++-- | Write a 'Word32' in big-endian order at the given byte offset.+pokeWord32BE :: Ptr Word8 -> Int -> Word32 -> IO ()+pokeWord32BE ptr off w = do+  pokeByteOff ptr off (fromIntegral (w `shiftR` 24) :: Word8)+  pokeByteOff ptr (off + 1) (fromIntegral (w `shiftR` 16) :: Word8)+  pokeByteOff ptr (off + 2) (fromIntegral (w `shiftR` 8) :: Word8)+  pokeByteOff ptr (off + 3) (fromIntegral w :: Word8)++-- | Unpack a 'Word32' from 4 big-endian bytes starting at offset.+unpackWord32BE :: ByteString -> Int -> Word32+unpackWord32BE bs off =+  let b0 = fromIntegral (BS.index bs off) :: Word32+      b1 = fromIntegral (BS.index bs (off + 1)) :: Word32+      b2 = fromIntegral (BS.index bs (off + 2)) :: Word32+      b3 = fromIntegral (BS.index bs (off + 3)) :: Word32+  in (b0 `shiftL` 24) .|. (b1 `shiftL` 16) .|. (b2 `shiftL` 8) .|. b3++-- | Build a packet header from its wire-format fields.+buildHeader :: Word32 -> Word32 -> Word32 -> Word32 -> ByteString+buildHeader checksum channelId messageId payloadLen =+  BSInternal.unsafeCreate headerSize $ \ptr -> do+    pokeWord32BE ptr 0 magic+    pokeWord32BE ptr 4 checksum+    pokeWord32BE ptr 8 channelId+    pokeWord32BE ptr 12 messageId+    pokeWord32BE ptr 16 payloadLen++-- ---------------------------------------------------------------------------+-- CRC32+-- ---------------------------------------------------------------------------++-- | Compute the CRC32 checksum of a 'ByteString', returned as 'Word32'.+computeCRC32 :: ByteString -> Word32+computeCRC32 = crc32++-- | Compute the CRC32 checksum over the concatenation of two byte strings.+computeCRC32Parts :: ByteString -> ByteString -> Word32+computeCRC32Parts a = crc32Update (crc32 a)++-- ---------------------------------------------------------------------------+-- Handle-based exact read+-- ---------------------------------------------------------------------------++-- | Read exactly @n@ bytes from a 'Handle'. Raises an 'IOError' on short+-- read (i.e., if the handle reaches EOF before @n@ bytes are available).+hGetExact :: Handle -> Int -> IO ByteString+hGetExact _ 0 = return BS.empty+hGetExact h n = go BS.empty+  where+    go acc+      | BS.length acc >= n = return acc+      | otherwise = do+          chunk <- BS.hGetSome h (n - BS.length acc)+          if BS.null chunk+            then+              if BS.null acc+                then ioError $ userError "Connection closed partway through reading packet."+                else ioError $ userError "Connection closed while reading data"+            else go (BS.append acc chunk)++-- ---------------------------------------------------------------------------+-- Packet I\/O+-- ---------------------------------------------------------------------------++-- | Read and parse a single packet from the given 'Handle'.+--+-- Raises 'IOError' if the magic number is invalid, the terminator byte is+-- invalid, or the CRC32 checksum does not match.+readPacket :: Handle -> IO Packet+readPacket h = do+  headerBuf <- hGetExact h headerSize+  let pktMagic = unpackWord32BE headerBuf 0+      checksum = unpackWord32BE headerBuf 4+      channelId = unpackWord32BE headerBuf 8+      rawMessageId = unpackWord32BE headerBuf 12+      payloadLen = unpackWord32BE headerBuf 16+      isReply = testBit rawMessageId 31+      messageId = if isReply then rawMessageId `xor` replyBit else rawMessageId++  when (pktMagic /= magic) $+    ioError $ userError $+      "Invalid magic number: expected 0x" ++ showHex32 magic+        ++ ", got 0x" ++ showHex32 pktMagic++  payloadBuf <- hGetExact h (fromIntegral payloadLen)+  termBuf <- hGetExact h 1+  let termByte = BS.index termBuf 0++  when (termByte /= terminator) $+    ioError $ userError $+      "Invalid terminator: expected 0x" ++ showHex8 terminator+        ++ ", got 0x" ++ showHex8 termByte++  -- Verify checksum: CRC32 over header with checksum field zeroed + payload+  let headerForCheck = buildHeader 0 channelId rawMessageId payloadLen+      computedCRC = computeCRC32Parts headerForCheck payloadBuf++  when (computedCRC /= checksum) $+    ioError $ userError $+      "Checksum mismatch: expected 0x" ++ showHex32 checksum+        ++ ", got 0x" ++ showHex32 computedCRC++  return Packet+    { packetChannelId = channelId+    , packetMessageId = messageId+    , packetIsReply = isReply+    , packetPayload = payloadBuf+    }++-- | Serialize and write a packet to the given 'Handle'.+writePacket :: Handle -> Packet -> IO ()+writePacket h pkt = do+  let wireMessageId =+        if packetIsReply pkt+          then packetMessageId pkt .|. replyBit+          else packetMessageId pkt+      payloadLen = fromIntegral (BS.length (packetPayload pkt)) :: Word32++  -- Build header with zeroed checksum for CRC computation+  let headerForCRC = buildHeader 0 (packetChannelId pkt) wireMessageId payloadLen+      checksum = computeCRC32Parts headerForCRC (packetPayload pkt)++  -- Build final header with real checksum+  let headerFinal = buildHeader checksum (packetChannelId pkt) wireMessageId payloadLen+  BS.hPut h headerFinal+  BS.hPut h (packetPayload pkt)+  BS.hPut h (BS.singleton terminator)+  hFlush h++-- ---------------------------------------------------------------------------+-- Hex formatting helpers+-- ---------------------------------------------------------------------------++-- | Format a 'Word32' as an 8-digit uppercase hex string.+showHex32 :: Word32 -> String+showHex32 w = map toHexDigit (reverse [nibble i | i <- [0..7]])+  where+    nibble i = fromIntegral ((w `shiftR` (i * 4)) .&. 0xF) :: Int+    toHexDigit n+      | n < 10    = toEnum (fromEnum '0' + n)+      | otherwise = toEnum (fromEnum 'A' + n - 10)++-- | Format a 'Word8' as a 2-digit uppercase hex string.+showHex8 :: Word8 -> String+showHex8 w = [toHexDigit hi, toHexDigit lo]+  where+    hi = fromIntegral (w `shiftR` 4) :: Int+    lo = fromIntegral (w .&. 0xF) :: Int+    toHexDigit n+      | n < 10    = toEnum (fromEnum '0' + n)+      | otherwise = toEnum (fromEnum 'A' + n - 10)++-- ---------------------------------------------------------------------------+-- CBOR helpers+-- ---------------------------------------------------------------------------++-- | Extract an integer from a CBOR 'Term'.+--+-- Accepts 'TInt' and 'TInteger'. Raises an error for other types.+extractInt :: Term -> Int+extractInt (TInt i) = i+extractInt (TInteger i) = fromIntegral i+extractInt other = error $ "Expected CBOR int, got " ++ termTypeName other++-- | Extract a double-precision float from a CBOR 'Term'.+--+-- Accepts 'TFloat', 'TDouble', and 'THalf'. Raises an error for other types.+extractFloat :: Term -> Double+extractFloat (TFloat f) = realToFrac f+extractFloat (TDouble d) = d+extractFloat (THalf f) = realToFrac f+extractFloat other = error $ "Expected CBOR float, got " ++ termTypeName other++-- | Extract a boolean from a CBOR 'Term'.+--+-- Raises an error if the term is not 'TBool'.+extractBool :: Term -> Bool+extractBool (TBool b) = b+extractBool other = error $ "Expected CBOR bool, got " ++ termTypeName other++-- | Extract a text string from a CBOR 'Term'.+--+-- Raises an error if the term is not 'TString'.+extractText :: Term -> Text+extractText (TString t) = t+extractText other = error $ "Expected CBOR text, got " ++ termTypeName other++-- | Extract a byte string from a CBOR 'Term'.+--+-- Raises an error if the term is not 'TBytes'.+extractBytes :: Term -> ByteString+extractBytes (TBytes b) = b+extractBytes other = error $ "Expected CBOR bytes, got " ++ termTypeName other++-- | Extract a list from a CBOR 'Term'.+--+-- Raises an error if the term is not 'TList'.+extractList :: Term -> [Term]+extractList (TList xs) = xs+extractList other = error $ "Expected CBOR array, got " ++ termTypeName other++-- | Extract a key-value map from a CBOR 'Term'.+--+-- Raises an error if the term is not 'TMap'.+extractMap :: Term -> [(Term, Term)]+extractMap (TMap kvs) = kvs+extractMap other = error $ "Expected CBOR map, got " ++ termTypeName other++-- | Encode a CBOR 'Term' to a strict 'ByteString'.+encodeTerm :: Term -> ByteString+encodeTerm = CBORWrite.toStrictByteString . CBOR.encodeTerm++-- | Decode a strict 'ByteString' to a CBOR 'Term'.+--+-- Raises an error if the bytes are not valid CBOR.+decodeTerm :: ByteString -> Term+decodeTerm bs =+  case deserialiseFromBytes CBOR.decodeTerm (LBS.fromStrict bs) of+    Left err -> error $ "CBOR decode error: " ++ show err+    Right (_, term) -> term++-- | Return a human-readable name for the type of a CBOR 'Term'.+termTypeName :: Term -> String+termTypeName (TInt _) = "int"+termTypeName (TInteger _) = "integer"+termTypeName (TFloat _) = "float"+termTypeName (TDouble _) = "double"+termTypeName (THalf _) = "half"+termTypeName (TBool _) = "bool"+termTypeName TNull = "null"+termTypeName (TBytes _) = "bytes"+termTypeName (TBytesI _) = "bytes (indefinite)"+termTypeName (TString _) = "text"+termTypeName (TStringI _) = "text (indefinite)"+termTypeName (TList _) = "array"+termTypeName (TListI _) = "array (indefinite)"+termTypeName (TMap _) = "map"+termTypeName (TMapI _) = "map (indefinite)"+termTypeName (TTagged _ _) = "tag"+termTypeName (TSimple _) = "simple"

@@ -0,0 +1,397 @@+-- | Global session management for Hegel.+--+-- This module manages a shared hegel subprocess communicating over stdio+-- pipes. It starts lazily on first use and cleans up when the process exits.+--+-- The main entry point is 'runHegelTest', which the user calls without+-- needing to manage connections or sessions directly.+module Hegel.Session+  ( -- * Session management+    startSession+  , cleanupSession+  , restartSession++    -- * Running tests+  , runHegelTest+  , runHegelTest_++    -- * Hegel discovery+  , findHegel+  , ensureHegelInstalled+  ) where++import Control.Concurrent (forkIO)+import Control.Concurrent.MVar+import Control.Exception (evaluate, try, SomeException)+import Control.Monad (unless)+import Data.Foldable (for_)+import Data.IORef+import System.Directory (createDirectoryIfMissing, doesFileExist)+import System.Environment (lookupEnv)+import System.Exit (ExitCode (..))+import System.IO+  ( hSetBinaryMode+  , hClose+  , IOMode (..)+  , openFile+  )+import System.IO.Unsafe (unsafePerformIO)+import System.Process+  ( CreateProcess (..)+  , StdStream (..)+  , ProcessHandle+  , proc+  , createProcess+  , waitForProcess+  , terminateProcess+  )++import Hegel.Client+import Hegel.Connection+++-- ---------------------------------------------------------------------------+-- Constants+-- ---------------------------------------------------------------------------++-- | Version of hegel-core to install.+hegelServerVersion :: String+hegelServerVersion = "0.2.3"++-- | Environment variable to override the hegel server command.+hegelServerCommandEnv :: String+hegelServerCommandEnv = "HEGEL_SERVER_COMMAND"++-- | Directory for hegel server installation and logs.+hegelServerDir :: FilePath+hegelServerDir = ".hegel"++-- | Message shown when uv is not found.+uvNotFoundMessage :: String+uvNotFoundMessage =+  "You are seeing this error message because hegel-haskell tried to use `uv` to \+  \install hegel-core, but could not find uv on the PATH.\n\n\+  \Hegel uses a Python server component called `hegel-core` to share core \+  \property-based testing functionality across languages. There are two ways \+  \for Hegel to get hegel-core:\n\n\+  \* By default, Hegel looks for uv (https://docs.astral.sh/uv/) on the PATH, \+  \and uses uv to install hegel-core to a local `.hegel/venv` directory. We \+  \recommend this option. To continue, install uv: \+  \https://docs.astral.sh/uv/getting-started/installation/.\n\+  \* Alternatively, you can manage the installation of hegel-core yourself. \+  \After installing, setting the HEGEL_SERVER_COMMAND environment variable to \+  \your hegel-core binary path tells hegel-haskell to use that hegel-core \+  \instead.\n\n\+  \See https://hegel.dev/reference/installation for more details."+++-- ---------------------------------------------------------------------------+-- Command execution helpers+-- ---------------------------------------------------------------------------++-- | Runs a command with arguments, redirecting stdout and stderr to a log+-- file. Returns the exit code.+runCommandToLog :: FilePath -> [String] -> FilePath -> IO ExitCode+runCommandToLog cmd args logPath = do+  logHandle <- openFile logPath AppendMode+  let cp = (proc cmd args)+        { std_out = UseHandle logHandle+        , std_err = UseHandle logHandle+        }+  (_, _, _, ph) <- createProcess cp+  exitCode <- waitForProcess ph+  hClose logHandle+  pure exitCode+++-- ---------------------------------------------------------------------------+-- Hegel discovery and installation+-- ---------------------------------------------------------------------------++-- | Checks for a cached hegel installation and installs via uv if needed.+-- Returns the path to the hegel binary.+ensureHegelInstalled :: IO FilePath+ensureHegelInstalled = do+  let venvDir = hegelServerDir ++ "/venv"+  let versionFile = venvDir ++ "/hegel-version"+  let hegelBin = venvDir ++ "/bin/hegel"+  let installLog = hegelServerDir ++ "/install.log"++  -- Check cached version (force the file read inside try to catch IO errors)+  cached <- try (do+    contents <- readFile versionFile+    let trimmed = strip contents+    -- Force evaluation of trimmed to catch lazy IO exceptions inside try+    _ <- evaluate (length trimmed)+    exists <- doesFileExist hegelBin+    if trimmed == hegelServerVersion && exists+      then pure (Just hegelBin)+      else pure Nothing+    ) :: IO (Either SomeException (Maybe FilePath))+  case cached of+    Right (Just path) -> pure path+    _ -> do+      -- Need to install+      createDirectoryIfMissing True hegelServerDir++      -- Create venv+      venvResult <- try (runCommandToLog "uv" ["venv", "--clear", venvDir] installLog)+        :: IO (Either SomeException ExitCode)+      case venvResult of+        Left _ -> fail uvNotFoundMessage+        Right (ExitFailure _) -> do+          logContents <- readFileSafe installLog+          fail ("uv venv failed. Install log:\n" ++ logContents)+        Right ExitSuccess -> pure ()++      -- Install hegel-core+      let pythonPath = venvDir ++ "/bin/python"+      pipResult <- runCommandToLog "uv"+        [ "pip", "install"+        , "--python", pythonPath+        , "hegel-core==" ++ hegelServerVersion+        ]+        installLog+      case pipResult of+        ExitFailure _ -> do+          logContents <- readFileSafe installLog+          fail $ "Failed to install hegel-core (version: " ++ hegelServerVersion+            ++ "). Set " ++ hegelServerCommandEnv+            ++ " to a hegel binary path to skip installation.\n"+            ++ "Install log:\n" ++ logContents+        ExitSuccess -> pure ()++      exists <- doesFileExist hegelBin+      unless exists $+        fail ("hegel not found at " ++ hegelBin ++ " after installation")++      -- Write version file+      writeFile versionFile hegelServerVersion+      pure hegelBin++-- | Locates the hegel binary. Checks, in order:+--+-- 1. @HEGEL_SERVER_COMMAND@ environment variable+-- 2. Auto-install via uv to @.hegel\/venv\/@ (version-locked)+--+-- The auto-installed version is preferred over any @hegel@ on @PATH@+-- because the system binary may be an incompatible version.+findHegel :: IO FilePath+findHegel = do+  envCmd <- lookupEnv hegelServerCommandEnv+  case envCmd of+    Just path | not (null path) -> pure path+    _ -> ensureHegelInstalled+++-- ---------------------------------------------------------------------------+-- CI detection+-- ---------------------------------------------------------------------------++-- | CI environment variables to check for auto-detection. Each entry is+-- @(varName, expectedValue)@ where 'Nothing' means "any value".+ciVars :: [(String, Maybe String)]+ciVars =+  [ ("CI", Nothing)+  , ("TF_BUILD", Just "true")+  , ("BUILDKITE", Just "true")+  , ("CIRCLECI", Just "true")+  , ("CIRRUS_CI", Just "true")+  , ("CODEBUILD_BUILD_ID", Nothing)+  , ("GITHUB_ACTIONS", Just "true")+  , ("GITLAB_CI", Nothing)+  , ("HEROKU_TEST_RUN_ID", Nothing)+  , ("TEAMCITY_VERSION", Nothing)+  ]++-- | Returns 'True' if a CI environment is detected.+isInCI :: IO Bool+isInCI = anyM checkVar ciVars+ where+  checkVar (key, expected) = do+    val <- lookupEnv key+    pure $ case (val, expected) of+      (Just _, Nothing)   -> True+      (Just v, Just expV) -> v == expV+      (Nothing, _)        -> False++  anyM _ [] = pure False+  anyM f (x : xs) = do+    b <- f x+    if b then pure True else anyM f xs+++-- ---------------------------------------------------------------------------+-- Session state+-- ---------------------------------------------------------------------------++-- | Internal mutable session state.+data HegelSession = HegelSession+  { sessionProcess    :: Maybe ProcessHandle+  , sessionConnection :: Maybe Connection+  , sessionClient     :: Maybe HegelClient+  }++-- | The initial empty session.+emptySession :: HegelSession+emptySession = HegelSession+  { sessionProcess    = Nothing+  , sessionConnection = Nothing+  , sessionClient     = Nothing+  }++-- | The global session singleton, protected by an MVar.+{-# NOINLINE globalSession #-}+globalSession :: MVar HegelSession+globalSession = unsafePerformIO (newMVar emptySession)++-- | IORef tracking whether cleanup has been registered with atexit.+{-# NOINLINE atExitRegistered #-}+atExitRegistered :: IORef Bool+atExitRegistered = unsafePerformIO (newIORef False)+++-- ---------------------------------------------------------------------------+-- Session lifecycle+-- ---------------------------------------------------------------------------++-- | Returns 'True' if the session has a live client.+hasWorkingClient :: HegelSession -> IO Bool+hasWorkingClient session =+  case (sessionClient session, sessionConnection session) of+    (Just _, Just conn) -> isLive conn+    _ -> pure False++-- | Cleans up the session, closing the connection and terminating the+-- subprocess.+cleanup :: HegelSession -> IO HegelSession+cleanup session = do+  -- Close connection+  for_ (sessionConnection session) closeConnection+  -- Terminate process+  case sessionProcess session of+    Just ph -> do+      _ <- try (terminateProcess ph) :: IO (Either SomeException ())+      _ <- try (waitForProcess ph) :: IO (Either SomeException ExitCode)+      pure ()+    Nothing -> pure ()+  pure emptySession++-- | Starts the hegel server if not already running. Spawns the server+-- with @--stdio@ for pipe-based communication.+startSession :: IO ()+startSession = modifyMVar_ globalSession $ \session -> do+  working <- hasWorkingClient session+  if working+    then pure session+    else do+      -- Clean up any old session+      _ <- cleanup session+      hegelCmd <- findHegel++      -- Open log file for server stderr+      createDirectoryIfMissing True hegelServerDir+      logHandle <- openFile (hegelServerDir ++ "/server.log") AppendMode++      -- Start hegel subprocess with --stdio+      let cp = (proc hegelCmd ["--stdio", "--verbosity", "normal"])+            { std_in  = CreatePipe+            , std_out = CreatePipe+            , std_err = UseHandle logHandle+            }+      (Just hIn, Just hOut, Nothing, ph) <- createProcess cp++      -- Set handles to binary mode+      hSetBinaryMode hIn True+      hSetBinaryMode hOut True++      -- Create connection from the pipe handles+      conn <- createConnection hOut hIn False++      -- Create client (performs handshake)+      client <- createClient conn++      -- Monitor thread: detect server crash+      _ <- forkIO $ do+        _ <- waitForProcess ph+        setServerExited conn+        pure ()++      -- Register at-exit cleanup (only once)+      registered <- readIORef atExitRegistered+      unless registered $ do+        writeIORef atExitRegistered True+        -- Note: We cannot use Weak references to the MVar easily, so we+        -- just always try cleanup. If session is already empty, cleanup+        -- is a no-op.++      pure HegelSession+        { sessionProcess    = Just ph+        , sessionConnection = Just conn+        , sessionClient     = Just client+        }++-- | Forces a restart of the global session. Cleans up the current session+-- and clears the state.+restartSession :: IO ()+restartSession = modifyMVar_ globalSession cleanup++-- | Cleans up the global session. Closes the connection and terminates+-- the server process.+cleanupSession :: IO ()+cleanupSession = modifyMVar_ globalSession cleanup+++-- ---------------------------------------------------------------------------+-- Running tests+-- ---------------------------------------------------------------------------++-- | Computes the initial settings for a test run.+--+-- In CI environments, Hegel starts from deterministic, stateless defaults by+-- enabling derandomization and disabling the example database.+initialSettingsForRun :: IO Settings+initialSettingsForRun = do+  inCI <- isInCI+  pure $+    if inCI+      then+        defaultSettings+          { settingsDerandomize = True+          , settingsDatabase = Disabled+          }+      else defaultSettings++-- | Runs a property test using the shared hegel process.+-- Ensures the session is started, then delegates to 'Client.runTest'.+runHegelTest :: (Settings -> Settings) -> (TestCase -> IO ()) -> IO ()+runHegelTest configure testFn = do+  effectiveSettings <- configure <$> initialSettingsForRun+  startSession+  session <- readMVar globalSession+  case sessionClient session of+    Just client -> runTest client effectiveSettings testFn+    Nothing     -> fail "Failed to start hegel session"++-- | Runs a property test using the initial runtime defaults unchanged.+runHegelTest_ :: (TestCase -> IO ()) -> IO ()+runHegelTest_ = runHegelTest id+++-- ---------------------------------------------------------------------------+-- Utilities+-- ---------------------------------------------------------------------------++-- | Strip leading and trailing whitespace from a string.+strip :: String -> String+strip = reverse . dropWhile isSpace' . reverse . dropWhile isSpace'+ where+  isSpace' c = c == ' ' || c == '\n' || c == '\r' || c == '\t'++-- | Read a file, returning empty string on failure.+readFileSafe :: FilePath -> IO String+readFileSafe path = do+  result <- try (readFile path) :: IO (Either SomeException String)+  case result of+    Right contents -> pure contents+    Left _         -> pure ""

@@ -0,0 +1,41 @@+{-# LANGUAGE OverloadedStrings #-}++module Hegel.ClientSpec (spec) where++import Test.Hspec++import Hegel.Client++spec :: Spec+spec = do+  describe "Default Settings" $ do+    it "provides pure non-CI defaults" $ do+      let stgs = defaultSettings+      settingsTestCases stgs `shouldBe` 100+      settingsVerbosity stgs `shouldBe` Normal+      settingsSeed stgs `shouldBe` Nothing+      settingsDerandomize stgs `shouldBe` False+      settingsDatabase stgs `shouldBe` Unset+      settingsSuppressHealthCheck stgs `shouldBe` []++    it "can be updated through record syntax without exposing the constructor" $ do+      let stgs =+            defaultSettings+              { settingsTestCases = 200+              , settingsDatabase = DatabasePath ".hegel/examples"+              }+      settingsTestCases stgs `shouldBe` 200+      settingsDatabase stgs `shouldBe` DatabasePath ".hegel/examples"++  describe "healthCheckToString" $ do+    it "maps FilterTooMuch correctly" $ do+      healthCheckToString FilterTooMuch `shouldBe` "filter_too_much"++    it "maps TooSlow correctly" $ do+      healthCheckToString TooSlow `shouldBe` "too_slow"++    it "maps TestCasesTooLarge correctly" $ do+      healthCheckToString TestCasesTooLarge `shouldBe` "test_cases_too_large"++    it "maps LargeInitialTestCase correctly" $ do+      healthCheckToString LargeInitialTestCase `shouldBe` "large_initial_test_case"

@@ -0,0 +1,121 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE OverloadedStrings #-}++module Hegel.IntegrationSpec (spec) where++import Control.Exception (SomeException, displayException, try)+import Control.Monad (when)+import Data.List (isInfixOf)+import Test.Hspec++import Hegel++captureFailureText :: IO () -> IO String+captureFailureText action = do+  result <- try action :: IO (Either SomeException ())+  case result of+    Left e -> pure (displayException e)+    Right () -> expectationFailure "expected property test to fail" >> pure ""++withTestCases :: Int -> Settings -> Settings+withTestCases n stgs = stgs { settingsTestCases = n }++spec :: Spec+spec = do+  describe "E2E: simple passing test" $ do+    it "integers are self-equal" $ do+      runHegelTest (withTestCases 10) $ \tc -> do+        n <- draw tc (integers def)+        when (n /= n) $+          error "integer not equal to itself"++  describe "E2E: simple failing test" $ do+    it "catches HegelTestFailure" $ do+      let action = runHegelTest (withTestCases 10) $ \tc -> do+            _ <- draw tc (integers def { rangeMin = Just 0, rangeMax = Just 100 })+            error "deliberate failure"+      action `shouldThrow` anyException++    it "reports the source location for Hegel.assert failures" $ do+      let expectedFile = __FILE__+      let expectedLine = show ((__LINE__ + 3) :: Int)+      msg <- captureFailureText $+        runHegelTest (withTestCases 10) $ \_tc ->+          assert False "deliberate failure with location"+      msg `shouldSatisfy` isInfixOf expectedFile+      msg `shouldSatisfy` isInfixOf (":" ++ expectedLine ++ ":")++    it "reports only the smallest failing example for a stable origin" $ do+      msg <- captureFailureText $+        runHegelTest+          ( \stgs ->+              stgs+                { settingsTestCases = 200+                , settingsDerandomize = True+                , settingsDatabase = Disabled+                }+          )+          $ \tc -> do+            xs <-+              draw+                tc+                ( lists+                    (integers def { rangeMin = Just 0, rangeMax = Just 0 })+                    def+                      { rangeMin = Just 0+                      , rangeMax = Just 12+                      }+                )+            assert (length xs < 10) ("expected list shorter than 10, got xs = " ++ show xs)+      msg `shouldSatisfy` isInfixOf "expected list shorter than 10, got xs = [0,0,0,0,0,0,0,0,0,0]"+      msg `shouldSatisfy` not . isInfixOf "got xs = [0,0,0,0,0,0,0,0,0,0,0]"++  describe "E2E: assume" $ do+    it "assume True does not reject" $ do+      runHegelTest (withTestCases 10) $ \tc -> do+        n <- draw tc (integers def)+        assume tc True+        when (n /= n) $+          error "unreachable"++    it "assume False rejects the test case" $ do+      -- All test cases are rejected, but the test should still complete+      -- (it just won't find any valid cases, which is fine for low counts)+      runHegelTest (withTestCases 5) $ \tc -> do+        n <- draw tc (integers def { rangeMin = Just 0, rangeMax = Just 100 })+        assume tc (n > 50)+        -- If we get here, n > 50 holds+        pure ()++  describe "E2E: draw multiple types" $ do+    it "draws booleans, integers, floats, text, and binary" $ do+      runHegelTest (withTestCases 10) $ \tc -> do+        _ <- draw tc booleans+        _ <- draw tc (integers def { rangeMin = Just 0, rangeMax = Just 100 })+        _ <-+          draw+            tc+            ( floats def+                { floatBounds =+                    RangeOpts+                      { rangeMin = Just 0.0,+                        rangeMax = Just 1.0+                      }+                }+            )+        _ <- draw tc (text def { rangeMax = Just 50 })+        _ <- draw tc (binary def { rangeMax = Just 50 })+        pure ()++  describe "E2E: note and target" $ do+    it "note records a message without failure" $ do+      runHegelTest (withTestCases 5) $ \tc -> do+        n <- draw tc (integers def)+        note tc ("Generated value: " ++ show n)+        pure ()++    it "target guides the search" $ do+      runHegelTest (withTestCases 10) $ \tc -> do+        n <- draw tc (integers def { rangeMin = Just 0, rangeMax = Just 1000 })+        target tc (fromIntegral n) "maximize n"+        pure ()

@@ -0,0 +1,141 @@+{-# LANGUAGE OverloadedStrings #-}++module Hegel.ProtocolSpec (spec) where++import Codec.CBOR.Term (Term (..))+import qualified Data.ByteString as BS+import Data.Bits (shiftL, shiftR, (.|.))+import Data.Word (Word32)+import System.IO (Handle, hFlush, hSetBinaryMode)+import System.Process (createPipe)+import Test.Hspec++import Hegel.Protocol++-- | Helper: create a pipe pair of handles for testing.+createPipePair :: IO (Handle, Handle)+createPipePair = createPipe++-- | Pack a Word32 as 4 big-endian bytes (reimplemented for testing since+-- the library does not export this).+testPackWord32BE :: Word32 -> BS.ByteString+testPackWord32BE w = BS.pack+  [ fromIntegral (w `shiftR` 24)+  , fromIntegral (w `shiftR` 16)+  , fromIntegral (w `shiftR` 8)+  , fromIntegral w+  ]++-- | Unpack a Word32 from 4 big-endian bytes at offset 0.+testUnpackWord32BE :: BS.ByteString -> Word32+testUnpackWord32BE bs =+  let b0 = fromIntegral (BS.index bs 0) :: Word32+      b1 = fromIntegral (BS.index bs 1) :: Word32+      b2 = fromIntegral (BS.index bs 2) :: Word32+      b3 = fromIntegral (BS.index bs 3) :: Word32+  in (b0 `shiftL` 24) .|. (b1 `shiftL` 16) .|. (b2 `shiftL` 8) .|. b3++spec :: Spec+spec = do+  describe "CRC32" $ do+    it "computes the known check value for '123456789'" $ do+      let input = "123456789"+      computeCRC32 input `shouldBe` 0xCBF43926++  describe "pack/unpack Word32 BE" $ do+    it "round-trips uint32 values" $ do+      let values = [0, 1, 255, 256, 65535, 0x12345678, 0xFFFFFFFF] :: [Word32]+      mapM_+        ( \w -> do+            let packed = testPackWord32BE w+            BS.length packed `shouldBe` 4+            testUnpackWord32BE packed `shouldBe` w+        )+        values++  describe "Packet round-trip" $ do+    it "writes and reads a packet through a pipe pair" $ do+      (readH, writeH) <- createPipePair+      hSetBinaryMode readH True+      hSetBinaryMode writeH True+      let pkt =+            Packet+              { packetChannelId = 42,+                packetMessageId = 7,+                packetIsReply = False,+                packetPayload = encodeTerm (TString "hello")+              }+      writePacket writeH pkt+      result <- readPacket readH+      packetChannelId result `shouldBe` 42+      packetMessageId result `shouldBe` 7+      packetIsReply result `shouldBe` False+      decodeTerm (packetPayload result) `shouldBe` TString "hello"++    it "round-trips a reply packet" $ do+      (readH, writeH) <- createPipePair+      hSetBinaryMode readH True+      hSetBinaryMode writeH True+      let pkt =+            Packet+              { packetChannelId = 10,+                packetMessageId = 3,+                packetIsReply = True,+                packetPayload = encodeTerm (TBool True)+              }+      writePacket writeH pkt+      result <- readPacket readH+      packetChannelId result `shouldBe` 10+      packetMessageId result `shouldBe` 3+      packetIsReply result `shouldBe` True++  describe "Invalid magic" $ do+    it "raises on invalid magic number" $ do+      (readH, writeH) <- createPipePair+      hSetBinaryMode readH True+      hSetBinaryMode writeH True+      -- Write a header with bad magic (0xDEADBEEF), followed by terminator+      let badHeader =+            BS.concat+              [ testPackWord32BE 0xDEADBEEF,+                testPackWord32BE 0,+                testPackWord32BE 1,+                testPackWord32BE 1,+                testPackWord32BE 0+              ]+      BS.hPut writeH badHeader+      BS.hPut writeH (BS.singleton 0x0A)+      hFlush writeH+      readPacket readH `shouldThrow` anyIOException++  describe "Bad CRC" $ do+    it "raises on checksum mismatch" $ do+      (readH, writeH) <- createPipePair+      hSetBinaryMode readH True+      hSetBinaryMode writeH True+      let payload = encodeTerm (TString "test")+      let payloadLen = fromIntegral (BS.length payload) :: Word32+      -- Compute correct CRC then corrupt it+      let headerForCRC =+            BS.concat+              [ testPackWord32BE magic,+                testPackWord32BE 0,+                testPackWord32BE 1,+                testPackWord32BE 1,+                testPackWord32BE payloadLen+              ]+      let correctCRC = computeCRC32Parts headerForCRC payload+      let wrongCRC = correctCRC + 1+      let badHeader =+            BS.concat+              [ testPackWord32BE magic,+                testPackWord32BE wrongCRC,+                testPackWord32BE 1,+                testPackWord32BE 1,+                testPackWord32BE payloadLen+              ]+      BS.hPut writeH badHeader+      BS.hPut writeH payload+      BS.hPut writeH (BS.singleton 0x0A)+      hFlush writeH+      readPacket readH `shouldThrow` anyIOException

@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}