Turn Traced into a comonad (#41)

* Turn Traced into a comonad

* tracedDePathFragment -> tracedPathFragmentParam

* Fixed tracedOp

Co-authored-by: iko <ilyakooo0@gmail.com>

openapi-diff.cabal

@@ -34,6 +34,7 @@ common common-options
                      , attoparsec
                      , bytestring
                      , containers
+                     , comonad
                      , deriving-aeson
                      , generic-data
                      , generic-monoid

src/OpenAPI/Checker/Orphans.hs

@@ -2,6 +2,7 @@
 
 module OpenAPI.Checker.Orphans (Step (..)) where
 
+import Control.Comonad.Env
 import Data.OpenApi
 import Data.Typeable
 import qualified Data.HashMap.Strict.InsOrd as IOHM
@@ -28,3 +29,7 @@ deriving stock instance Ord ParamLocation
 
 instance (Ord k, Ord v) => Ord (IOHM.InsOrdHashMap k v) where
   compare xs ys = compare (IOHM.toList xs) (IOHM.toList ys)
+
+deriving stock instance (Eq e, Eq (w a)) => Eq (EnvT e w a)
+deriving stock instance (Ord e, Ord (w a)) => Ord (EnvT e w a)
+deriving stock instance (Show e, Show (w a)) => Show (EnvT e w a)

src/OpenAPI/Checker/References.hs

@@ -1,7 +1,6 @@
 module OpenAPI.Checker.References
   ( TracedReferences
   , dereference
-  , dereferenceTraced
   )
 where
 
@@ -16,17 +15,12 @@ import OpenAPI.Checker.Trace
 type TracedReferences root a = Map Reference (Traced root a)
 
 dereference
-  :: Typeable a
-  => Definitions a
-  -> Referenced a
-  -> Traced (Referenced a) a
-dereference _ (Inline a) = Traced (step InlineStep) a
-dereference defs (Ref r@(Reference ref)) =
-  Traced (step $ ReferencedStep r) (fromJust $ IOHM.lookup ref defs)
-
-dereferenceTraced
   :: Typeable a
   => Definitions a
   -> Traced r (Referenced a)
   -> Traced r a
-dereferenceTraced defs (Traced t x) = retrace t $ dereference defs x
+dereference defs x = case extract x of
+  Inline a
+    -> traced (ask x >>> step InlineStep) a
+  Ref r@(Reference ref)
+    -> traced (ask x >>> step (ReferencedStep r)) (fromJust $ IOHM.lookup ref defs)

src/OpenAPI/Checker/Run.hs

@@ -1,12 +1,12 @@
 module OpenAPI.Checker.Run (runChecker) where
 
-import Control.Category
 import Data.Aeson
 import qualified Data.ByteString.Char8 as BSC
 import Data.HList
 import qualified Data.Yaml as Yaml
 import OpenAPI.Checker.Options
 import OpenAPI.Checker.Subtree
+import OpenAPI.Checker.Trace
 import OpenAPI.Checker.Validate.OpenApi ()
 import Prelude hiding (id, (.))
 
@@ -24,7 +24,7 @@ runChecker = do
                 fail "Exiting"
               Right s -> pure s
           Right s -> pure s
-  a <- parseSchema (clientFile opts)
+  a <- traced Root <$> parseSchema (clientFile opts)
-  b <- parseSchema (serverFile opts)
+  b <- traced Root <$> parseSchema (serverFile opts)
-  let report = runCompatFormula (pure id) $ checkCompatibility HNil (ProdCons a b)
+  let report = runCompatFormula $ checkCompatibility HNil (ProdCons a b)
   BSC.putStrLn $ Yaml.encode report

src/OpenAPI/Checker/Subtree.hs

@@ -2,19 +2,13 @@ module OpenAPI.Checker.Subtree
   ( APIStep (..)
   , Subtree (..)
   , CompatM (..)
+  , CompatFormula'
   , CompatFormula
   , ProdCons (..)
   , HasUnsupportedFeature (..)
-  , swapRoles
   , swapProdCons
-  , checkProdCons
   , SubtreeCheckIssue (..)
   , runCompatFormula
-  , withTrace
-  , localM
-  , localTrace
-  , localStep
-  , localTrace'
   , anyOfM
   , anyOfAt
   , issueAtTrace
@@ -23,8 +17,8 @@ module OpenAPI.Checker.Subtree
   )
 where
 
+import Control.Comonad.Env
 import Control.Monad.Identity
-import Control.Monad.Reader
 import Control.Monad.State
 import Data.Aeson
 import Data.Functor.Compose
@@ -58,29 +52,19 @@ instance Applicative ProdCons where
   pure x = ProdCons x x
   ProdCons fp fc <*> ProdCons xp xc = ProdCons (fp xp) (fc xc)
 
-newtype CompatM t a = CompatM
+newtype CompatM a = CompatM
   { unCompatM
-    :: ReaderT
+    :: (StateT (MemoState VarRef) Identity) a
-           (ProdCons (Trace OpenApi t))
-           (StateT (MemoState VarRef) Identity)
-           a
   }
   deriving newtype
     ( Functor
     , Applicative
     , Monad
-    , MonadReader (ProdCons (Trace OpenApi t))
     , MonadState (MemoState VarRef)
     )
 
-type CompatFormula t = Compose (CompatM t) (FormulaF SubtreeCheckIssue OpenApi)
+type CompatFormula' f r = Compose CompatM (FormulaF f r)
-
+type CompatFormula = CompatFormula' SubtreeCheckIssue OpenApi
--- | Swaps roles of producer and consumer. Used when we check the @Response@ at
--- least. In response producer and consumer swap their places because response
--- is generated by consumer and parsed by producer.
-swapRoles :: CompatFormula t a -> CompatFormula t a
-swapRoles (Compose r) = Compose $ do
-  local swapProdCons r
 
 class (Typeable t, Ord (CheckIssue t), Show (CheckIssue t)) => Subtree (t :: Type) where
   type CheckEnv t :: [Type]
@@ -93,14 +77,14 @@ class (Typeable t, Ord (CheckIssue t), Show (CheckIssue t)) => Subtree (t :: Typ
   normalizeTrace :: Trace OpenApi t -> Trace OpenApi t
   normalizeTrace = id
 
-  checkCompatibility :: HasAll (CheckEnv t) xs => HList xs -> ProdCons t -> CompatFormula t ()
+  checkCompatibility
+    :: HasAll (CheckEnv t) xs
+    => HList xs
+    -> ProdCons (Traced OpenApi t)
+    -> CompatFormula ()
 
 {-# WARNING normalizeTrace "It must be refactored. Does nothing for now" #-}
 
-checkProdCons :: (Subtree t, HasAll (CheckEnv t) env) => HList env -> ProdCons (Traced r t) -> CompatFormula r ()
-checkProdCons env (ProdCons (Traced p x) (Traced c y)) =
-  localTrace (ProdCons p c) $ checkCompatibility env $ ProdCons x y
-
 class HasUnsupportedFeature x where
   hasUnsupportedFeature :: x -> Bool
 
@@ -141,76 +125,41 @@ instance ToJSON (SubtreeCheckIssue t) where
   toJSON (SubtreeCheckIssue i) = toJSON i
 
 runCompatFormula
-  :: ProdCons (Trace OpenApi t)
+  :: CompatFormula' f r a
-  -> Compose (CompatM t) (FormulaF f r) a
   -> Either (T.TracePrefixTree f r) a
-runCompatFormula env (Compose f) =
+runCompatFormula (Compose f) =
-  calculate . runIdentity . runMemo 0 . (`runReaderT` env) . unCompatM $ f
+  calculate . runIdentity . runMemo 0 . unCompatM $ f
-
-withTrace
-  :: (ProdCons (Trace OpenApi a) -> Compose (CompatM a) (FormulaF f r) x)
-  -> Compose (CompatM a) (FormulaF f r) x
-withTrace k = Compose $ do
-  xs <- ask
-  getCompose $ k xs
-
-localM
-  :: ProdCons (Trace a b)
-  -> CompatM b x
-  -> CompatM a x
-localM xs (CompatM k) =
-  CompatM $ ReaderT $ \env -> runReaderT k ((>>>) <$> env <*> xs)
-
-localTrace
-  :: ProdCons (Trace a b)
-  -> Compose (CompatM b) (FormulaF f r) x
-  -> Compose (CompatM a) (FormulaF f r) x
-localTrace xs (Compose h) = Compose (localM xs h)
-
-localStep
-  :: Steppable a b
-  => Step a b
-  -> Compose (CompatM b) (FormulaF f r) x
-  -> Compose (CompatM a) (FormulaF f r) x
-localStep xs (Compose h) = Compose (localM (pure $ step xs) h)
-
-localTrace'
-  :: ProdCons (Trace OpenApi b)
-  -> Compose (CompatM b) (FormulaF f r) x
-  -> Compose (CompatM a) (FormulaF f r) x
-localTrace' xs (Compose (CompatM k)) = Compose $ CompatM$ ReaderT $ \_ -> runReaderT k xs
 
 issueAtTrace
-  :: Subtree t => Trace OpenApi t -> CheckIssue t -> CompatFormula s a
+  :: Subtree t
+  => Trace r t
+  -> CheckIssue t
+  -> CompatFormula' SubtreeCheckIssue r a
 issueAtTrace xs issue = Compose $ pure $ anError $ AnItem xs $ SubtreeCheckIssue issue
 
 issueAt
-  :: Subtree t
+  :: (Subtree t, ComonadEnv (Trace r t) w)
-  => (forall x. ProdCons x -> x)
+  => w x
   -> CheckIssue t
-  -> CompatFormula t a
+  -> CompatFormula' SubtreeCheckIssue r a
-issueAt f issue = Compose $ do
+issueAt x = issueAtTrace (ask x)
-  xs <- asks f
-  pure $ anError $ AnItem xs $ SubtreeCheckIssue issue
 
 anyOfM
-  :: Ord (f t)
+  :: Subtree t
   => Trace r t
-  -> f t
+  -> CheckIssue t
-  -> [Compose (CompatM t) (FormulaF f r) a]
+  -> [CompatFormula' SubtreeCheckIssue r a]
-  -> Compose (CompatM t) (FormulaF f r) a
+  -> CompatFormula' SubtreeCheckIssue r a
 anyOfM xs issue fs =
-  Compose $ (`eitherOf` AnItem xs issue) <$> sequenceA (getCompose <$> fs)
+  Compose $ (`eitherOf` AnItem xs (SubtreeCheckIssue issue)) <$> sequenceA (getCompose <$> fs)
 
 anyOfAt
-  :: Subtree t
+  :: (Subtree t, ComonadEnv (Trace r t) w)
-  => (forall x. ProdCons x -> x)
+  => w x
   -> CheckIssue t
-  -> [CompatFormula t a]
+  -> [CompatFormula' SubtreeCheckIssue r a]
-  -> CompatFormula t a
+  -> CompatFormula' SubtreeCheckIssue r a
-anyOfAt f issue fs = Compose $ do
+anyOfAt x = anyOfM (ask x)
-  xs <- asks f
-  (`eitherOf` AnItem xs (SubtreeCheckIssue issue)) <$> sequenceA (getCompose <$> fs)
 
 fixpointKnot
   :: MonadState (MemoState VarRef) m
@@ -222,7 +171,9 @@ fixpointKnot =
     , tieKnot = \i x -> pure $ maxFixpoint i x
     }
 
-memo :: Subtree t => CompatFormula t () -> CompatFormula t ()
+memo
-memo (Compose f) = Compose $ do
+  :: (Typeable r, Subtree t)
-  pxs <- asks (fmap normalizeTrace)
+  => (ProdCons (Traced r t) -> CompatFormula ())
-  memoWithKnot fixpointKnot f pxs
+  -> (ProdCons (Traced r t) -> CompatFormula ())
+memo f pc  = Compose $ do
+  memoWithKnot fixpointKnot (getCompose $ f pc) (ask <$> pc)

src/OpenAPI/Checker/Trace.hs

@@ -9,18 +9,21 @@ module OpenAPI.Checker.Trace
   , _DiffTrace
   , AnItem (..)
   , step
-  , Traced (..)
+  , Traced
-  , mapTraced
+  , traced
-  , retrace
-  , deTraced
 
     -- * Reexports
   , (>>>)
   , (<<<)
+  , extract
+  , ask
+  , asks
+  , local
   )
 where
 
 import Control.Category
+import Control.Comonad.Env
 import Control.Lens
 import Data.Kind
 import Data.Type.Equality
@@ -117,20 +120,7 @@ instance Typeable r => Ord (AnItem f r) where
           Root -> compare (someTypeRep xs) (someTypeRep ys)
           Snoc _ _ -> compare (someTypeRep xs) (someTypeRep ys)
 
-data Traced r a = Traced {getTrace :: Trace r a, getTraced :: a}
+type Traced r a = Env (Trace r a) a
-  deriving (Eq, Show)
 
--- | Reverse lexicographical order, so that getTraced is a monotonous function
+traced :: Trace r a -> a -> Traced r a
-instance Ord a => Ord (Traced r a) where
+traced = env
-  compare (Traced t1 a1) (Traced t2 a2) = compare a1 a2 <> compare t1 t2
-
-mapTraced :: (Trace r a -> Trace r b) -> (a -> b) -> Traced r a -> Traced r b
-mapTraced f g (Traced t a) = Traced (f t) (g a)
-
-retrace :: Trace s r -> Traced r a -> Traced s a
-retrace xs (Traced t a) = Traced (xs >>> t) a
-
-deTraced :: Traced r a -> (Trace r a, a)
-deTraced (Traced a b) = (a, b)
-
--- type APath = AnItem Proxy

src/OpenAPI/Checker/Validate/MediaTypeObject.hs

@@ -1,9 +1,11 @@
 {-# OPTIONS_GHC -Wno-orphans #-}
 
-module OpenAPI.Checker.Validate.MediaTypeObject () where
+module OpenAPI.Checker.Validate.MediaTypeObject
+  ( CheckIssue(..)
+  ) where
 
+import Control.Lens
 import Data.Foldable as F
-import Data.Functor
 import Data.HList
 import Data.HashMap.Strict.InsOrd as IOHM
 import Data.Map.Strict as M
@@ -15,13 +17,21 @@ import OpenAPI.Checker.Trace
 import OpenAPI.Checker.Validate.Products
 import OpenAPI.Checker.Validate.Schema ()
 
+tracedSchema :: Traced r MediaTypeObject -> Maybe (Traced r (Referenced Schema))
+tracedSchema mto = _mediaTypeObjectSchema (extract mto) <&> traced (ask mto >>> step MediaTypeSchema)
+
+tracedEncoding :: Traced r MediaTypeObject -> InsOrdHashMap Text (Traced r Encoding)
+tracedEncoding mto = IOHM.mapWithKey (\k -> traced (ask mto >>> step (MediaTypeParamEncoding k)))
+  $ _mediaTypeObjectEncoding $ extract mto
+
 instance Subtree MediaTypeObject where
   type CheckEnv MediaTypeObject =
     '[ MediaType
      , ProdCons (Definitions Schema)
      ]
   data CheckIssue MediaTypeObject
-    = MediaEncodingMissing Text
+    = RequestMediaTypeNotFound
+    | ResponseMediaTypeMissing
     | MediaEncodingIncompat
     | MediaTypeSchemaRequired
     deriving (Eq, Ord, Show)
@@ -32,11 +42,10 @@ instance Subtree MediaTypeObject where
        | otherwise -> pure ()
     -- If consumer requires schema then producer must produce compatible
     -- request
-    for_ (_mediaTypeObjectSchema c) $ \consRef ->
+    for_ (tracedSchema c) $ \consRef ->
-        case _mediaTypeObjectSchema p of
+        case tracedSchema p of
-          Nothing -> issueAt producer MediaTypeSchemaRequired
+          Nothing -> issueAt p MediaTypeSchemaRequired
-          Just prodRef -> localStep MediaTypeSchema
+          Just prodRef -> checkCompatibility env $ ProdCons prodRef consRef
-            $ checkCompatibility env $ ProdCons prodRef consRef
     pure ()
     where
       mediaType = getH @MediaType env
@@ -44,23 +53,25 @@ instance Subtree MediaTypeObject where
         let
           -- Parameters of the media type are product-like entities
           getEncoding mt = M.fromList
-            $ (IOHM.toList $ _mediaTypeObjectEncoding mt) <&> \(k, enc) ->
+            $ (IOHM.toList $ tracedEncoding mt) <&> \(k, enc) ->
             ( k
             , ProductLike
-              { traced = Traced (step $ MediaTypeParamEncoding k) enc
+              { tracedValue = enc
               , required = True } )
           encProdCons = getEncoding <$> prodCons
-        in checkProducts MediaEncodingMissing
+        in checkProducts (const MediaEncodingMissing)
            (const $ checkCompatibility HNil) encProdCons
 
 instance Subtree Encoding where
   type CheckEnv Encoding = '[]
-  data CheckIssue Encoding = EncodingNotSupported
+  data CheckIssue Encoding
+    = MediaEncodingMissing
+    | EncodingNotSupported
     --  FIXME: Support only JSON body for now. Then Encoding is checked only for
     --  multipart/form-url-encoded
     deriving (Eq, Ord, Show)
-  checkCompatibility _env _prodCons =
+  checkCompatibility _env pc =
-    issueAt producer EncodingNotSupported
+    issueAt (producer pc) EncodingNotSupported
 
 instance Steppable MediaTypeObject (Referenced Schema) where
   data Step MediaTypeObject (Referenced Schema) = MediaTypeSchema

src/OpenAPI/Checker/Validate/OpenApi.hs

@@ -13,22 +13,25 @@ import OpenAPI.Checker.Subtree
 import OpenAPI.Checker.Trace
 import OpenAPI.Checker.Validate.ProcessedPathItem
 
+tracedPaths :: Traced r OpenApi -> Traced r ProcessedPathItems
+tracedPaths oa = traced (ask oa >>> step OpenApiPathsStep)
+  (processPathItems . IOHM.toList . _openApiPaths . extract $ oa)
+
 instance Subtree OpenApi where
   type CheckEnv OpenApi = '[]
   data CheckIssue OpenApi
     deriving (Eq, Ord, Show)
   checkCompatibility _ prodCons = do
-    let cs = _openApiComponents <$> prodCons
+    let cs = _openApiComponents . extract <$> prodCons
-    localStep OpenApiPathsStep $
+    checkCompatibility @ProcessedPathItems
-      checkCompatibility
+      ((_componentsRequestBodies <$> cs)
-        ((_componentsRequestBodies <$> cs)
+         `HCons` (_componentsParameters <$> cs)
-           `HCons` (_componentsParameters <$> cs)
+         `HCons` (_componentsSecuritySchemes <$> cs)
-           `HCons` (_componentsSecuritySchemes <$> cs)
+         `HCons` (_componentsResponses <$> cs)
-           `HCons` (_componentsResponses <$> cs)
+         `HCons` (_componentsHeaders <$> cs)
-           `HCons` (_componentsHeaders <$> cs)
+         `HCons` (_componentsSchemas <$> cs)
-           `HCons` (_componentsSchemas <$> cs)
+         `HCons` HNil)
-           `HCons` HNil)
+      (tracedPaths <$> prodCons)
-        (processPathItems . IOHM.toList . _openApiPaths <$> prodCons)
 
 instance Steppable OpenApi ProcessedPathItems where
   data Step OpenApi ProcessedPathItems = OpenApiPathsStep

src/OpenAPI/Checker/Validate/Operation.hs

@@ -2,7 +2,10 @@
 {-# OPTIONS_GHC -Wno-name-shadowing #-}
 
 module OpenAPI.Checker.Validate.Operation
-  ( MatchedOperation(..)
+  ( MatchedOperation (..)
+  , CheckIssue (..)
+  , OperationMethod(..)
+  , pathItemMethod
   ) where
 
 
@@ -17,15 +20,11 @@ import Data.Text (Text)
 import OpenAPI.Checker.References
 import OpenAPI.Checker.Subtree
 import OpenAPI.Checker.Trace
-import OpenAPI.Checker.Validate.Param ()
+import OpenAPI.Checker.Validate.Param
 import OpenAPI.Checker.Validate.PathFragment
 import OpenAPI.Checker.Validate.Products
-import OpenAPI.Checker.Validate.RequestBody ()
+import OpenAPI.Checker.Validate.RequestBody
 import OpenAPI.Checker.Validate.Responses ()
-import OpenAPI.Checker.Validate.SecurityRequirement ()
-import OpenAPI.Checker.Validate.Server ()
-
--- data ParamKey
 
 data MatchedOperation = MatchedOperation
   { operation :: !Operation
@@ -41,6 +40,31 @@ type ParamKey = (ParamLocation, Text)
 paramKey :: Param -> ParamKey
 paramKey param = (_paramIn param, _paramName param)
 
+tracedParameters :: Traced r MatchedOperation -> [Traced r (Referenced Param)]
+tracedParameters oper =
+  [ traced (ask oper >>> step (OperationParamsStep i)) x
+  | (i, x) <- zip [0..] $ _operationParameters . operation $ extract oper
+  ]
+
+tracedRequestBody :: Traced r MatchedOperation -> Maybe (Traced r (Referenced RequestBody))
+tracedRequestBody oper = _operationRequestBody (operation $ extract oper) <&> traced (ask oper >>> step OperationRequestBodyStep)
+
+tracedResponses :: Traced r MatchedOperation -> Traced r Responses
+tracedResponses oper = traced (ask oper >>> step OperationResponsesStep)
+  $ _operationResponses . operation $ extract oper
+
+tracedSecurity :: Traced r MatchedOperation -> [Traced r SecurityRequirement]
+tracedSecurity oper =
+  [ traced (ask oper >>> step (OperationSecurityRequirementStep i)) x
+  | (i, x) <- zip [0..] $ _operationSecurity . operation $ extract oper
+  ]
+
+tracedServers :: Traced r MatchedOperation -> [Traced r Server]
+tracedServers oper =
+  [ traced (ask oper >>> step (OperationServerStep i)) x
+  | (i, x) <- zip [0..] $ _operationServers . operation $ extract oper
+  ]
+
 instance Subtree MatchedOperation where
   type CheckEnv MatchedOperation =
     '[ ProdCons (Definitions Param)
@@ -51,17 +75,11 @@ instance Subtree MatchedOperation where
      , ProdCons (Definitions Schema)
      ]
   data CheckIssue MatchedOperation
-    = ParamNotMatched ParamLocation Text
+    = OperationMissing OperationMethod
-    -- ^ Non-path param has no pair
-    | PathFragmentNotMatched Int
-    -- ^ Path fragment with given position has no match
-    | NoRequestBody
     | CallbacksNotSupported
-    | SecurityRequirementNotMet Int -- security indexs
-    | ServerNotConsumed Int -- server index
     deriving (Eq, Ord, Show)
-  checkCompatibility env prodCons = withTrace $ \myTrace -> do
+  checkCompatibility env prodCons = do
-    checkParameters myTrace
+    checkParameters
     checkRequestBodies
     checkResponses
     checkCallbacks
@@ -69,88 +87,84 @@ instance Subtree MatchedOperation where
     checkServers
     pure ()
     where
-      checkParameters myTrace = do
+      checkParameters = do
         let
           -- Merged parameters got from Operation and PathItem in one
           -- place. First element is path params, second is non-path params
           tracedParams :: ProdCons ([Traced OpenApi Param], [Traced OpenApi Param])
-          tracedParams = getParams <$> myTrace <*> paramDefs <*> prodCons
+          tracedParams = getParams <$> paramDefs <*> prodCons
-          getParams root defs mp =
+          getParams defs mp =
             let
               operationParamsMap :: Map ParamKey (Traced OpenApi Param)
               operationParamsMap = M.fromList $ do
-                paramRef <- _operationParameters $ operation mp
+                paramRef <- tracedParameters mp
                 let
-                  tracedParam = retrace root
+                  param = dereference defs paramRef
-                    $ dereferenceTraced defs
+                  key = paramKey . extract $ param
-                    $ Traced (step $ OperationParamsStep) paramRef
+                pure (key, param)
-                  key = paramKey $ getTraced tracedParam
-                pure (key, tracedParam)
               pathParamsMap :: Map ParamKey (Traced OpenApi Param)
               pathParamsMap = M.fromList $ do
-                param <- pathParams mp
+                param <- pathParams . extract $ mp
-                pure (paramKey $ getTraced param, param)
+                pure (paramKey . extract $ param, param)
               params = M.elems $ M.union operationParamsMap pathParamsMap
               -- We prefer params from Operation
               splitted = L.partition
-                (\p -> (_paramIn $ getTraced p) == ParamPath) params
+                (\p -> (_paramIn . extract $ p) == ParamPath) params
             in splitted
         checkNonPathParams $ snd <$> tracedParams
         checkPathParams $ fst <$> tracedParams
         pure ()
-      checkNonPathParams :: ProdCons [Traced OpenApi Param] -> CompatFormula MatchedOperation ()
+      checkNonPathParams :: ProdCons [Traced OpenApi Param] -> CompatFormula ()
       checkNonPathParams params = do
         let
           elements = getEls <$> params
-          getEls traced = M.fromList $ do
+          getEls params = M.fromList $ do
-            p <- traced
+            p <- params
             let
-              param = getTraced p
+              k = (_paramIn . extract $ p, _paramName . extract $ p)
-              k = (_paramIn param, _paramName param)
               v = ProductLike
-                { traced = p
+                { tracedValue = p
-                , required = fromMaybe False $ _paramRequired param
+                , required = fromMaybe False . _paramRequired . extract $ p
                 }
             pure (k, v)
-          check _ param = do
+          check param = do
             checkCompatibility @Param (singletonH schemaDefs) param
-        checkProducts' (uncurry ParamNotMatched) check elements
+        checkProducts (ParamNotMatched . snd) (const check) elements
+      checkPathParams :: ProdCons [Traced OpenApi Param] -> CompatFormula ()
       checkPathParams pathParams = do
         let
           fragments :: ProdCons [Traced OpenApi PathFragmentParam]
           fragments = getFragments <$> pathParams <*> prodCons
-          getFragments params mop = (getPathFragments mop) params
+          getFragments params mop = getPathFragments (extract mop) params
           -- Feed path parameters to the fragments getter
-          check _ frags = checkCompatibility @PathFragmentParam env frags
+          check frags = checkCompatibility @PathFragmentParam env frags
-          elements = fragments <&> \frags -> M.fromList $ zip [0..] $ do
+          elements = fragments <&> \frags -> M.fromList $ zip [0 :: Int ..] $ do
             frag <- frags
             pure $ ProductLike
-              { traced = frag
+              { tracedValue = frag
               , required = True }
-        checkProducts' PathFragmentNotMatched check elements
+        checkProducts (const PathFragmentNotMatched) (const check) elements
       checkRequestBodies = do
         let
-          check _ reqBody = checkCompatibility @RequestBody env reqBody
+          check reqBody = checkCompatibility @RequestBody env reqBody
           elements = getReqBody <$> bodyDefs <*> prodCons
           getReqBody bodyDef mop = M.fromList $ do
-            bodyRef <- F.toList $ _operationRequestBody $ operation mop
+            bodyRef <- F.toList . tracedRequestBody $ mop
             let
-              traced = dereferenceTraced bodyDef
+              body = dereference bodyDef bodyRef
-                $ Traced (step $ OperationRequestBodyStep) bodyRef
-              required = fromMaybe False
-                $ _requestBodyRequired $ getTraced traced
-              elt = ProductLike { traced, required }
             -- Single element map
-            pure ((), elt)
+            pure ((), ProductLike
-        checkProducts (const NoRequestBody) check elements
+              { tracedValue = body
+              , required = fromMaybe False . _requestBodyRequired . extract $ body
+              })
+        checkProducts (const NoRequestBody) (const check) elements
       checkResponses = do
         let
-          resps = (_operationResponses . operation) <$> prodCons
           respEnv = HCons (swapProdCons respDefs)
             $ HCons (swapProdCons headerDefs)
             $ HCons (swapProdCons schemaDefs) HNil
-        localStep OperationResponsesStep
+          resps = tracedResponses <$> prodCons
-          $ swapRoles $ checkCompatibility respEnv $ swapProdCons resps
+        checkCompatibility respEnv $ swapProdCons resps
       checkCallbacks = pure () -- (error "FIXME: not implemented")
       checkOperationSecurity = pure () -- (error "FIXME: not implemented")
       checkServers = pure () -- (error "FIXME: not implemented")
@@ -160,8 +174,30 @@ instance Subtree MatchedOperation where
       schemaDefs = getH @(ProdCons (Definitions Schema)) env
       paramDefs = getH @(ProdCons (Definitions Param)) env
 
+data OperationMethod = 
+  GetMethod
+  | PutMethod
+  | PostMethod
+  | DeleteMethod
+  | OptionsMethod
+  | HeadMethod
+  | PatchMethod
+  | TraceMethod
+  deriving (Eq, Ord, Show)
+
+pathItemMethod :: OperationMethod -> PathItem -> Maybe Operation 
+pathItemMethod = \case
+  GetMethod -> _pathItemGet
+  PutMethod -> _pathItemPut
+  PostMethod -> _pathItemPost
+  DeleteMethod -> _pathItemDelete
+  OptionsMethod -> _pathItemOptions
+  HeadMethod -> _pathItemHead
+  PatchMethod -> _pathItemPatch
+  TraceMethod -> _pathItemTrace
+
 instance Steppable MatchedOperation (Referenced Param) where
-  data Step MatchedOperation (Referenced Param) = OperationParamsStep
+  data Step MatchedOperation (Referenced Param) = OperationParamsStep Int
     deriving (Eq, Ord, Show)
 
 instance Steppable MatchedOperation (Referenced RequestBody) where
@@ -173,9 +209,9 @@ instance Steppable MatchedOperation Responses where
     deriving (Eq, Ord, Show)
 
 instance Steppable MatchedOperation SecurityRequirement where
-  data Step MatchedOperation SecurityRequirement = OperationSecurityRequirementStep
+  data Step MatchedOperation SecurityRequirement = OperationSecurityRequirementStep Int
     deriving (Eq, Ord, Show)
 
 instance Steppable MatchedOperation Server where
-  data Step MatchedOperation Server = OperationServerStep
+  data Step MatchedOperation Server = OperationServerStep Int
     deriving (Eq, Ord, Show)

src/OpenAPI/Checker/Validate/Param.hs

@@ -1,11 +1,15 @@
 {-# OPTIONS_GHC -Wno-orphans #-}
 {-# OPTIONS_GHC -fno-warn-name-shadowing #-}
 
-module OpenAPI.Checker.Validate.Param () where
+module OpenAPI.Checker.Validate.Param
+  ( CheckIssue (..)
+  ) where
 
+import Control.Lens
 import Control.Monad
 import Data.Maybe
 import Data.OpenApi
+import Data.Text
 import OpenAPI.Checker.Orphans
 import OpenAPI.Checker.Subtree
 import OpenAPI.Checker.Trace
@@ -38,10 +42,14 @@ paramEncoding p = EncodingStyle
       ParamQuery -> Just $ fromMaybe False $ _paramAllowReserved p
       _ -> Nothing
 
+tracedSchema :: Traced r Param -> Maybe (Traced r (Referenced Schema))
+tracedSchema par = _paramSchema (extract par) <&> traced (ask par >>> step ParamSchema)
+
 instance Subtree Param where
   type CheckEnv Param = '[ProdCons (Definitions Schema)]
   data CheckIssue Param
-    = ParamNameMismatch
+    = ParamNotMatched Text
+    | ParamNameMismatch
     -- ^ Params have different names
     | ParamEmptinessIncompatible
     -- ^ Consumer requires non-empty param, but producer gives emptyable
@@ -53,28 +61,28 @@ instance Subtree Param where
     | ParamSchemaMismatch
     -- ^ One of schemas not presented
     deriving (Eq, Ord, Show)
-  checkCompatibility env (ProdCons p c) = do
+  checkCompatibility env pc@(ProdCons p c) = do
-    when (_paramName p /= _paramName c)
+    when (_paramName (extract p) /= _paramName (extract c))
-      $ issueAt producer ParamNameMismatch
+      $ issueAt p ParamNameMismatch
-    when ((fromMaybe False $ _paramRequired c) &&
+    when ((fromMaybe False . _paramRequired . extract $ c) &&
-          not (fromMaybe False $ _paramRequired p))
+          not (fromMaybe False . _paramRequired . extract $ p))
-      $ issueAt producer ParamRequired
+      $ issueAt p ParamRequired
-    case (_paramIn p, _paramIn c) of
+    case (_paramIn . extract $ p, _paramIn . extract $ c) of
       (ParamQuery, ParamQuery) -> do
         -- Emptiness is only for query params
-        when ((fromMaybe False $ _paramAllowEmptyValue p)
+        when ((fromMaybe False . _paramAllowEmptyValue . extract $ p)
-              && not (fromMaybe False $ _paramAllowEmptyValue c))
+              && not (fromMaybe False . _paramAllowEmptyValue . extract $ c))
-          $ issueAt producer ParamEmptinessIncompatible
+          $ issueAt p ParamEmptinessIncompatible
       (a, b) | a == b -> pure ()
-      _ -> issueAt producer ParamPlaceIncompatible
+      _ -> issueAt p ParamPlaceIncompatible
-    unless (paramEncoding p == paramEncoding c)
+    unless (paramEncoding (extract p) == paramEncoding (extract c))
-      $ issueAt producer ParamStyleMismatch
+      $ issueAt p ParamStyleMismatch
-    case (_paramSchema p, _paramSchema c) of
+    case tracedSchema <$> pc of
-      (Just prodSchema, Just consSchema) -> localStep ParamSchema
+      ProdCons (Just prodSchema) (Just consSchema) -> do
-        $ checkCompatibility env (ProdCons prodSchema consSchema)
+        checkCompatibility env $ ProdCons prodSchema consSchema
-      (Nothing, Nothing) -> pure ()
+      ProdCons Nothing Nothing -> pure ()
-      (Nothing, Just _consSchema) -> issueAt producer ParamSchemaMismatch
+      ProdCons Nothing (Just _consSchema) -> issueAt p ParamSchemaMismatch
-      (Just _prodSchema, Nothing) -> pure ()
+      ProdCons (Just _prodSchema) Nothing -> pure ()
       -- If consumer doesn't care then why we should?
     pure ()
 

src/OpenAPI/Checker/Validate/PathFragment.hs

@@ -2,6 +2,7 @@ module OpenAPI.Checker.Validate.PathFragment
   ( parsePath
   , PathFragment (..)
   , PathFragmentParam
+  , CheckIssue (..)
   )
 where
 
@@ -40,32 +41,16 @@ instance (Typeable param) => Steppable (PathFragment param) Param where
   data Step (PathFragment param) Param = StaticPathParam Text
     deriving (Eq, Ord, Show)
 
-instance Subtree PathFragmentParam where
+tracedPathFragmentParam :: Traced OpenApi PathFragmentParam -> Traced OpenApi Param
-  type CheckEnv PathFragmentParam =
+tracedPathFragmentParam pfp = case extract pfp of
-    '[ ProdCons (Definitions Schema) ]
+  StaticPath s -> traced (ask pfp >>> step (StaticPathParam s))
-  data CheckIssue PathFragmentParam =
+    $ mempty
-    PathFragmentsDontMatch Text Text
+    { _paramRequired = Just True
-    deriving (Eq, Ord, Show)
+    , _paramIn = ParamPath
-  -- This case isn't strictly needed. It is here for optimization.
+    , _paramAllowEmptyValue = Just False
-  checkCompatibility _ ProdCons {producer = (StaticPath x), consumer = (StaticPath y)} =
+    , _paramAllowReserved = Just False
-    if x == y
+    , _paramSchema = Just $ Inline $ staticStringSchema s }
-      then pure ()
+  DynamicPath p -> p
-      else issueAt consumer (PathFragmentsDontMatch x y)
-  checkCompatibility env prodCons = withTrace $ \myTrace -> do
-    let
-      tracedParams = dePathFragment <$> myTrace <*> prodCons
-      dePathFragment root = \case
-        StaticPath s -> retrace root $ Traced (step $ StaticPathParam s)
-          $ mempty
-          { _paramRequired = Just True
-          , _paramIn = ParamPath
-          , _paramAllowEmptyValue = Just False
-          , _paramAllowReserved = Just False
-          , _paramSchema = Just $ Inline $ staticStringSchema s }
-        DynamicPath p -> p
-      params = getTraced <$> tracedParams
-      paramTrace = getTrace <$> tracedParams
-    localTrace' paramTrace $ checkCompatibility env params
 
 staticStringSchema :: Text -> Schema
 staticStringSchema t =
@@ -74,3 +59,18 @@ staticStringSchema t =
     , _schemaType = Just OpenApiString
     , _schemaEnum = Just [A.String t]
     }
+
+instance Subtree PathFragmentParam where
+  type CheckEnv PathFragmentParam =
+    '[ ProdCons (Definitions Schema) ]
+  data CheckIssue PathFragmentParam
+    = PathFragmentNotMatched
+    | PathFragmentsDontMatch Text Text
+    deriving (Eq, Ord, Show)
+  -- This case isn't strictly needed. It is here for optimization.
+  checkCompatibility _ (ProdCons (extract -> StaticPath x) c@(extract -> StaticPath y))
+    = if x == y
+      then pure ()
+      else issueAt c (PathFragmentsDontMatch x y)
+  checkCompatibility env prodCons = do
+    checkCompatibility env (tracedPathFragmentParam <$> prodCons)

src/OpenAPI/Checker/Validate/ProcessedPathItem.hs

@@ -9,6 +9,7 @@ module OpenAPI.Checker.Validate.ProcessedPathItem
   )
 where
 
+import Control.Comonad.Env
 import Control.Monad
 import Data.Foldable as F
 import Data.Functor
@@ -52,29 +53,24 @@ instance Subtree ProcessedPathItems where
     | AllPathsFailed FilePath
     -- When several paths match given but all checks failed
     deriving (Eq, Ord, Show)
-  checkCompatibility env (ProdCons p c) = do
+  checkCompatibility env pc@(ProdCons p c) = do
     -- Each path generated by producer must be handled by consumer with exactly
     -- one way
-    for_ (unProcessedPathItems p) $ \ prodItem -> do
+    for_ (unProcessedPathItems . extract $ p) $ \ prodItem -> do
       let
         prodPath = path prodItem
         matchedItems = do
-          consItem <- unProcessedPathItems c
+          consItem <- unProcessedPathItems . extract $ c
           matched <- F.toList $ matchingPathItems $ ProdCons prodItem consItem
           return matched
       case matchedItems of
-        [] -> issueAt producer $ NoPathsMatched prodPath
+        [] -> issueAt p $ NoPathsMatched prodPath
-        [matched] -> do
+        [match] -> checkCompatibility env (retraced <$> pc <*> match)
-          -- Checking exact match with no wrapper
+        matches -> anyOfAt c (AllPathsFailed prodPath) $ do
-          let trace = matchedTrace <$> matched
-          localTrace trace $ checkCompatibility env matched
-        matches -> anyOfAt consumer (AllPathsFailed prodPath) $ do
           match <- matches
-          let trace = matchedTrace <$> match
+          pure $ checkCompatibility env (retraced <$> pc <*> match)
-          pure $ localTrace trace $ checkCompatibility env match
     where
-      matchedTrace :: MatchedPathItem -> Trace ProcessedPathItems MatchedPathItem
+      retraced pc mpi = traced (ask pc >>> step (MatchedPathStep $ matchedPath mpi)) mpi
-      matchedTrace mpi = step $ MatchedPathStep $ matchedPath mpi
 
 -- | Preliminary checks two paths for compatibility.  Returns Nothing if two
 -- paths obviously do not match: static parts differ or count of path elements
@@ -109,6 +105,25 @@ data MatchedPathItem = MatchedPathItem
   -- ^ Pre-parsed path from PathItem
   }
 
+tracedParameters :: Traced r MatchedPathItem -> [Traced r (Referenced Param)]
+tracedParameters mpi =
+  [ traced (ask mpi >>> step (PathItemParam i)) x
+  | (i, x) <- L.zip [0..] $ _pathItemParameters . pathItem $ extract mpi
+  ]
+
+-- TODO: simplify?
+tracedFragments :: Traced r MatchedPathItem -> [Env (Trace r PathFragmentParam) (PathFragment Text)]
+tracedFragments mpi =
+  [ env (ask mpi >>> step (PathFragmentStep i)) x
+  | (i, x) <- L.zip [0..] $ pathFragments $ extract mpi
+  ]
+
+tracedMethod
+  :: OperationMethod
+  -> Traced r MatchedPathItem
+  -> Maybe (Env (Trace r MatchedOperation) Operation)
+tracedMethod s mpi = env (ask mpi >>> step (OperationMethodStep s)) <$> (pathItemMethod s . pathItem . extract $ mpi)
+
 instance Subtree MatchedPathItem where
   type CheckEnv MatchedPathItem =
     '[ ProdCons (Definitions Param)
@@ -119,63 +134,46 @@ instance Subtree MatchedPathItem where
      , ProdCons (Definitions Schema)
      ]
   data CheckIssue MatchedPathItem
-    = OperationMissing (Step MatchedPathItem MatchedOperation)
     deriving (Eq, Ord, Show)
-  checkCompatibility env prodCons = withTrace $ \rootTrace -> do
+  checkCompatibility env prodCons = do
     let
       paramDefs = getH @(ProdCons (Definitions Param)) env
-      pathTracedParams = getPathParams <$> rootTrace <*> paramDefs <*> prodCons
+      pathTracedParams = getPathParams <$> paramDefs <*> prodCons
       getPathParams
-        :: Trace OpenApi MatchedPathItem
+        :: Definitions Param
-        -> Definitions Param
+        -> Traced r MatchedPathItem
-        -> MatchedPathItem
+        -> [Traced r Param]
-        -> [Traced OpenApi Param]
+      getPathParams defs mpi = do
-      getPathParams root defs mpi = do
+        paramRef <- tracedParameters mpi
-        paramRef <- _pathItemParameters $ pathItem mpi
+        pure $ dereference defs paramRef
-        let
+      pathTracedFragments = mkPathFragments <$> prodCons
-          traced = dereferenceTraced defs
+      mkPathFragments mpi operationParams =
-            $ Traced (step PathItemParam) paramRef
-          res = retrace root traced
-        pure res
-      pathTracedFragments = mkPathFragments <$> rootTrace <*> prodCons
-      mkPathFragments myRoot mpi operationParams =
         --  operationParams will be known on Operation check stage, so we give a
         --  function, returning fragments
         let
           paramsMap :: Map Text (Traced OpenApi Param)
           paramsMap = M.fromList $ do
             tracedParam <- operationParams
-            let pname = _paramName $ getTraced tracedParam
+            let pname = _paramName . extract $ tracedParam
             pure (pname, tracedParam)
-          fragments :: [PathFragmentParam]
+          convertFragment = \case
-          fragments = (pathFragments mpi) <&> \case
             StaticPath t -> StaticPath t
             DynamicPath pname -> DynamicPath
               $ fromMaybe (error $ "Param not found " <> T.unpack pname)
               $ M.lookup pname paramsMap
-          tracedFragments :: [Traced OpenApi PathFragmentParam]
+        in tracedFragments mpi <&> fmap convertFragment
-          tracedFragments = L.zip [0..] fragments <&> \(pos, frag) ->
-            retrace myRoot $ Traced (step $ PathFragmentStep pos) frag
-        in tracedFragments
       operations = getOperations <$> pathTracedParams <*> pathTracedFragments <*> prodCons
       getOperations pathParams getPathFragments mpi = M.fromList $ do
-        (getOp, s) <-
+        (i, getOp) <- (\m -> (m, tracedMethod m)) <$>
-          [ (_pathItemGet, GetStep)
+          [GetMethod, PutMethod, PostMethod, DeleteMethod, OptionsMethod, HeadMethod, PatchMethod, DeleteMethod]
-          , (_pathItemPut, PutStep)
+        operation <- F.toList $ getOp mpi
-          , (_pathItemPost, PostStep)
-          , (_pathItemDelete, DeleteStep)
-          , (_pathItemOptions, OptionsStep)
-          , (_pathItemHead, HeadStep)
-          , (_pathItemPatch, PatchStep)
-          , (_pathItemTrace, TraceStep) ]
-        operation <- F.toList $ getOp $ pathItem mpi
         -- Got only Justs here
-        let mop = MatchedOperation { operation , pathParams, getPathFragments }
+        let retraced = \op -> MatchedOperation { operation = op, pathParams, getPathFragments }
-        pure (s, Traced (step s) mop)
+        pure (i, retraced <$> operation)
-      check _ pc = checkCompatibility @MatchedOperation env pc
+      check pc = checkCompatibility @MatchedOperation env pc
     -- Operations are sum-like entities. Use step to operation as key because
     -- why not
-    checkSums OperationMissing check operations
+    checkSums OperationMissing (const check) operations
 
 
 instance Steppable ProcessedPathItems MatchedPathItem where
@@ -183,19 +181,11 @@ instance Steppable ProcessedPathItems MatchedPathItem where
     deriving (Eq, Ord, Show)
 
 instance Steppable MatchedPathItem MatchedOperation where
-  data Step MatchedPathItem MatchedOperation
+  data Step MatchedPathItem MatchedOperation = OperationMethodStep OperationMethod
-    = GetStep
-    | PutStep
-    | PostStep
-    | DeleteStep
-    | OptionsStep
-    | HeadStep
-    | PatchStep
-    | TraceStep
     deriving (Eq, Ord, Show)
 
 instance Steppable MatchedPathItem (Referenced Param) where
-  data Step MatchedPathItem (Referenced Param) = PathItemParam
+  data Step MatchedPathItem (Referenced Param) = PathItemParam Int
     deriving (Eq, Ord, Show)
 
 instance Steppable MatchedPathItem PathFragmentParam where

src/OpenAPI/Checker/Validate/Products.hs

@@ -14,58 +14,36 @@ This module abstracts this logic for arbitrary elements -}
 
 module OpenAPI.Checker.Validate.Products
   ( checkProducts
-  , checkProducts'
   , ProductLike(..)
   ) where
 
 import Data.Foldable
-import Data.Functor
 import Data.Map.Strict (Map)
 import qualified Data.Map.Strict as M
-import Data.OpenApi.Internal
 import OpenAPI.Checker.Subtree
 import OpenAPI.Checker.Trace
 
 -- | Some entity which is product-like
 data ProductLike root a = ProductLike
-  { traced :: Traced root a
+  { tracedValue :: Traced root a
   , required :: Bool
   }
 
-checkProducts'
+checkProducts
-  :: forall k root t
+  :: forall k r t
-  .  (Subtree root, Ord k)
+  .  (Subtree t, Ord k)
-  => (k -> CheckIssue root)
+  => (k -> CheckIssue t)
   -- ^ No required element found
-  -> (k -> ProdCons t -> CompatFormula t ())
+  -> (k -> ProdCons (Traced r t) -> CompatFormula' SubtreeCheckIssue r ())
-  -> ProdCons (Map k (ProductLike OpenApi t))
+  -> ProdCons (Map k (ProductLike r t))
-  -> CompatFormula root ()
+  -> CompatFormula' SubtreeCheckIssue r ()
-checkProducts' noElt check (ProdCons p c) = for_ (M.toList c) $ \(key, consElt) ->
+checkProducts noElt check (ProdCons p c) = for_ (M.toList c) $ \(key, consElt) ->
   case M.lookup key p of
     Nothing -> case required consElt of
-      True  -> issueAt producer $ noElt key
+      True  -> issueAt (tracedValue consElt) $ noElt key
       False -> pure ()
     Just prodElt -> do
       let
-        elts :: ProdCons (ProductLike OpenApi t)
+        elts :: ProdCons (ProductLike r t)
         elts = ProdCons prodElt consElt
-        trace = getTrace . traced <$> elts
+      check key (tracedValue <$> elts)
-        elements = getTraced . traced <$> elts
-      localTrace' trace $ check key elements
-
-checkProducts
-  :: forall k root t
-  .  (Subtree root, Ord k)
-  => (k -> CheckIssue root)
-  -- ^ No required element found
-  -> (k -> ProdCons t -> CompatFormula t ())
-  -> ProdCons (Map k (ProductLike root t))
-  -> CompatFormula root ()
-checkProducts noElt check prodCons = withTrace $ \myTrace ->
-  let
-    retracedPC = retracePC <$> myTrace <*> prodCons
-    retracePC rootTrace els = els <&> \productLike ->
-      ProductLike
-      { traced = retrace rootTrace $ traced productLike
-      , required = required productLike }
-  in checkProducts' noElt check retracedPC

src/OpenAPI/Checker/Validate/RequestBody.hs

@@ -1,11 +1,10 @@
 {-# OPTIONS_GHC -Wno-orphans #-}
 
 module OpenAPI.Checker.Validate.RequestBody
-  (
+  ( CheckIssue (..)
   )
 where
 
-import Data.Functor
 import Data.HList
 import Data.HashMap.Strict.InsOrd as IOHM
 import Data.Map.Strict as M
@@ -14,32 +13,31 @@ import Data.OpenApi
 import Network.HTTP.Media (MediaType)
 import OpenAPI.Checker.Subtree
 import OpenAPI.Checker.Trace
-import OpenAPI.Checker.Validate.MediaTypeObject ()
+import OpenAPI.Checker.Validate.MediaTypeObject
 import OpenAPI.Checker.Validate.Sums
 
+tracedContent :: Traced r RequestBody -> IOHM.InsOrdHashMap MediaType (Traced r MediaTypeObject)
+tracedContent resp = IOHM.mapWithKey (\k -> traced (ask resp >>> step (RequestMediaTypeObject k)))
+  $ _requestBodyContent $ extract resp
+
 instance Subtree RequestBody where
   type CheckEnv RequestBody =
     '[ ProdCons (Definitions Schema) ]
   data CheckIssue RequestBody
-    = RequestBodyRequired
+    = NoRequestBody
-    | RequestMediaTypeNotFound MediaType
+    | RequestBodyRequired
     deriving (Eq, Ord, Show)
   checkCompatibility env prodCons@(ProdCons p c) =
-    if not (fromMaybe False $ _requestBodyRequired p)
+    if not (fromMaybe False . _requestBodyRequired . extract $ p)
-        && (fromMaybe False $ _requestBodyRequired c)
+        && (fromMaybe False . _requestBodyRequired . extract $ c)
-    then issueAt producer RequestBodyRequired
+    then issueAt p RequestBodyRequired
     else
       -- Media type object are sums-like entities.
       let
         check mediaType pc = checkCompatibility @MediaTypeObject (HCons mediaType env) pc
         sumElts = getSum <$> prodCons
-        getSum rb = M.fromList
+        getSum rb = M.fromList . IOHM.toList $ tracedContent rb
-          $ (IOHM.toList $ _requestBodyContent rb) <&> \(mt, mto) ->
+      in checkSums (const RequestMediaTypeNotFound) check sumElts
-          ( mt
-          , Traced
-            { getTraced = mto
-            , getTrace = step $ RequestMediaTypeObject mt })
-      in checkSums RequestMediaTypeNotFound check sumElts
 
 instance Steppable RequestBody MediaTypeObject where
   data Step RequestBody MediaTypeObject = RequestMediaTypeObject MediaType

src/OpenAPI/Checker/Validate/Responses.hs

@@ -6,6 +6,7 @@ module OpenAPI.Checker.Validate.Responses
   )
 where
 
+import Control.Lens
 import Data.Foldable
 import Data.HList
 import Data.HashMap.Strict.InsOrd as IOHM
@@ -16,18 +17,22 @@ import Network.HTTP.Media (MediaType)
 import OpenAPI.Checker.References
 import OpenAPI.Checker.Subtree
 import OpenAPI.Checker.Trace
-import OpenAPI.Checker.Validate.MediaTypeObject ()
+import OpenAPI.Checker.Validate.MediaTypeObject
 import OpenAPI.Checker.Validate.Products
 import OpenAPI.Checker.Validate.Schema ()
 import OpenAPI.Checker.Validate.Sums
 
+tracedResponses :: Traced r Responses -> IOHM.InsOrdHashMap HttpStatusCode (Traced r (Referenced Response))
+tracedResponses resp = IOHM.mapWithKey (\k -> traced (ask resp >>> step (ResponseCodeStep k)))
+  $ _responsesResponses $ extract resp
+
 instance Subtree Responses where
   type CheckEnv Responses =
     '[ ProdCons (Definitions Response)
      , ProdCons (Definitions Header)
      , ProdCons (Definitions Schema)
      ]
-  data CheckIssue Responses = ResponseCodeNotFound HttpStatusCode
+  data CheckIssue Responses
     deriving (Eq, Ord, Show)
   -- Roles are already swapped. Producer is a server and consumer is a
   -- client. Response codes are sum-like entity because we can answer with only
@@ -35,15 +40,20 @@ instance Subtree Responses where
   checkCompatibility env prodCons = do
     let
       defs = getH @(ProdCons (Definitions Response)) env
-      check _ resps = checkCompatibility @Response env resps
+      check resps = checkCompatibility @Response env resps
       elements = getEls <$> defs <*> prodCons
       getEls respDef resps = M.fromList $ do
-        (code, respRef) <- IOHM.toList $ _responsesResponses resps
+        (code, respRef) <- IOHM.toList $ tracedResponses resps
-        let
+        pure (code, dereference respDef respRef)
-          traced = dereferenceTraced respDef
+    checkSums (const ResponseCodeNotFound) (const check) elements
-            $ Traced (step $ ResponseCodeStep code) respRef
+
-        pure (code, traced)
+tracedContent :: Traced r Response -> IOHM.InsOrdHashMap MediaType (Traced r MediaTypeObject)
-    checkSums ResponseCodeNotFound check elements
+tracedContent resp = IOHM.mapWithKey (\k -> traced (ask resp >>> step (ResponseMediaObject k)))
+  $ _responseContent $ extract resp
+
+tracedHeaders :: Traced r Response -> IOHM.InsOrdHashMap HeaderName (Traced r (Referenced Header))
+tracedHeaders resp = IOHM.mapWithKey (\k -> traced (ask resp >>> step (ResponseHeader k)))
+  $ _responseHeaders $ extract resp
 
 instance Subtree Response where
   type CheckEnv Response =
@@ -51,8 +61,7 @@ instance Subtree Response where
      , ProdCons (Definitions Schema)
      ]
   data CheckIssue Response
-    = ResponseMediaTypeMissing MediaType
+    = ResponseCodeNotFound
-    | ResponseHeaderMissing HeaderName
     deriving (Eq, Ord, Show)
   checkCompatibility env prodCons = do
     -- Roles are already swapped. Producer is a server and consumer is a client
@@ -67,46 +76,44 @@ instance Subtree Response where
             let mtEnv = HCons mediaType $ env
             in checkCompatibility @MediaTypeObject mtEnv mtObj
           elements = getEls <$> prodCons
-          getEls resp = M.fromList $ do
+          getEls resp = M.fromList . IOHM.toList $ tracedContent resp
-            (mediaType, mtObj) <- IOHM.toList $ _responseContent resp
+        checkSums (const ResponseMediaTypeMissing) check elements
-            let traced = Traced (step $ ResponseMediaObject mediaType) mtObj
-            pure (mediaType, traced)
-        checkSums ResponseMediaTypeMissing check elements
 
       checkHeaders = do
         -- Headers are product-like entities
         let
-          check _hname hdrs = checkCompatibility @Header env hdrs
+          check hdrs = checkCompatibility @Header env hdrs
           elements = getEls <$> headerDefs <*> prodCons
           getEls headerDef resp = M.fromList $ do
-            (hname, headerRef) <- IOHM.toList $ _responseHeaders resp
+            (hname, headerRef) <- IOHM.toList $ tracedHeaders resp
-            let
+            let header = dereference headerDef headerRef
-              traced = dereferenceTraced headerDef
+            pure (hname, ProductLike
-                $ Traced (step $ ResponseHeader hname) headerRef
+              { tracedValue = header
-              required = fromMaybe False $ _headerRequired $ getTraced traced
+              , required = fromMaybe False . _headerRequired . extract $ header
-              elt = ProductLike { traced, required }
+              })
-            pure (hname, elt)
+        checkProducts (const ResponseHeaderMissing) (const check) elements
-        checkProducts ResponseHeaderMissing check elements
       headerDefs = getH @(ProdCons (Definitions Header)) env
 
+tracedSchema :: Traced r Header -> Maybe (Traced r (Referenced Schema))
+tracedSchema hdr = _headerSchema (extract hdr) <&> traced (ask hdr >>> step HeaderSchema)
+
 instance Subtree Header where
   type CheckEnv Header = '[ProdCons (Definitions Schema)]
   data CheckIssue Header
-    = RequiredHeaderMissing
+    = ResponseHeaderMissing
+    | RequiredHeaderMissing
     | NonEmptyHeaderRequired
     | HeaderSchemaRequired
     deriving (Eq, Ord, Show)
   checkCompatibility env (ProdCons p c) = do
-    if (fromMaybe False $ _headerRequired c) && not (fromMaybe False $ _headerRequired p)
+    if (fromMaybe False $ _headerRequired $ extract c) && not (fromMaybe False $ _headerRequired $ extract p)
-      then issueAt producer RequiredHeaderMissing else pure ()
+      then issueAt p RequiredHeaderMissing else pure ()
-    if not (fromMaybe False $ _headerAllowEmptyValue c) && (fromMaybe False $ _headerAllowEmptyValue p)
+    if not (fromMaybe False $ _headerAllowEmptyValue $ extract c) && (fromMaybe False $ _headerAllowEmptyValue $ extract p)
-      then issueAt producer NonEmptyHeaderRequired else pure ()
+      then issueAt p NonEmptyHeaderRequired else pure ()
-    for_ (_headerSchema c) $ \consRef ->
+    for_ (tracedSchema c) $ \consRef ->
-      case (_headerSchema p) of
+      case tracedSchema p of
-        Nothing -> issueAt producer HeaderSchemaRequired
+        Nothing -> issueAt p HeaderSchemaRequired
-        Just prodRef -> do
+        Just prodRef -> checkCompatibility env (ProdCons prodRef consRef)
-          localStep HeaderSchema
-            $ checkCompatibility env $ ProdCons prodRef consRef
     pure ()
 
 instance Steppable Responses (Referenced Response) where

src/OpenAPI/Checker/Validate/Schema.hs

@@ -14,7 +14,11 @@ module OpenAPI.Checker.Validate.Schema
 
 import Algebra.Lattice
 import Control.Applicative
-import Control.Monad.Reader
+import Control.Arrow
+import Control.Comonad.Env hiding (env)
+import Control.Lens hiding (cons)
+import Control.Monad.Reader hiding (ask)
+import qualified Control.Monad.Reader as R
 import Control.Monad.Writer
 import qualified Data.Aeson as A
 import Data.Coerce
@@ -154,7 +158,7 @@ deriving stock instance Ord (Condition t)
 deriving stock instance Show (Condition t)
 
 data SomeCondition where
-  SomeCondition :: Typeable t => Condition t -> SomeCondition
+  SomeCondition :: Typeable t => Traced OpenApi (Condition t) -> SomeCondition
 
 instance Eq SomeCondition where
   SomeCondition x == SomeCondition y = case cast x of
@@ -200,8 +204,8 @@ isSingleton s
   | otherwise = Nothing
 
 pattern Conjunct :: [Traced r (Condition t)] -> M.Map (Condition t) (Trace r (Condition t))
-pattern Conjunct xs <- (map (uncurry $ flip Traced) . M.toList -> xs)
+pattern Conjunct xs <- (map (uncurry $ flip traced) . M.toList -> xs)
-  where Conjunct xs = M.fromList [(x, t) | Traced t x <- xs]
+  where Conjunct xs = M.fromList $ (extract &&& ask) <$> xs
 {-# COMPLETE Conjunct #-}
 
 pattern SingleConjunct :: [Traced r (Condition t)] -> JsonFormula r t
@@ -218,19 +222,16 @@ instance BoundedJoinSemiLattice (JsonFormula r t) where
 instance BoundedMeetSemiLattice (JsonFormula r t) where
   top = TopFormula
 
-singletonFormula :: Trace r (Condition t) -> Condition t -> JsonFormula r t
-singletonFormula t x = SingleConjunct [Traced t x]
-
 foldLattice
   :: BoundedLattice l
   => (Traced r (Condition t) -> l)
   -> JsonFormula r t
   -> l
 foldLattice f (DNF xss) = S.foldl' (\z w ->
-  z \/ M.foldlWithKey' (\x y t -> x /\ f (Traced t y)) top w) bottom xss
+  z \/ M.foldlWithKey' (\x y t -> x /\ f (traced t y)) top w) bottom xss
 
 satisfiesFormula :: TypedValue t -> JsonFormula r t -> Bool
-satisfiesFormula val = foldLattice (satisfiesTyped val . getTraced)
+satisfiesFormula val = foldLattice (satisfiesTyped val . extract)
 
 data ForeachType (f :: JsonType -> Type) = ForeachType
   { forNull :: f 'Null
@@ -345,22 +346,52 @@ instance Steppable Schema (Referenced Schema) where
     = AllOfStep Int
     | OneOfStep Int
     | AnyOfStep Int
-    | ItemsStep
+    | ItemsObjectStep
+    | ItemsArrayStep Int
     | AdditionalPropertiesStep
     | PropertiesStep Text
     deriving (Eq, Ord, Show)
 
 type ProcessM = ReaderT (Definitions Schema) (Writer (T.TracePrefixTree SubtreeCheckIssue OpenApi))
 
-warn :: Subtree t => Trace OpenApi t -> CheckIssue t -> ProcessM ()
+warn
-warn t x = tell $ T.singleton $ AnItem t $ SubtreeCheckIssue x
+  :: (Subtree t, ComonadEnv (Trace OpenApi t) w)
+  => w x -> CheckIssue t -> ProcessM ()
+warn t issue = tell $ T.singleton $ AnItem (ask t) $ SubtreeCheckIssue issue
 
 processRefSchema
   :: Traced OpenApi (Referenced Schema)
   -> ProcessM (ForeachType (JsonFormula OpenApi))
 processRefSchema x = do
-  defs <- ask
+  defs <- R.ask
-  processSchema $ dereferenceTraced defs x
+  processSchema $ dereference defs x
+
+tracedAllOf :: Traced r Schema -> Maybe [Traced r (Referenced Schema)]
+tracedAllOf sch = _schemaAllOf (extract sch) <&> \xs ->
+    [ traced (ask sch >>> step (AllOfStep i)) x | (i, x) <- zip [0..] xs ]
+
+tracedAnyOf :: Traced r Schema -> Maybe [Traced r (Referenced Schema)]
+tracedAnyOf sch = _schemaAnyOf (extract sch) <&> \xs ->
+    [ traced (ask sch >>> step (AnyOfStep i)) x | (i, x) <- zip [0..] xs ]
+
+tracedOneOf :: Traced r Schema -> Maybe [Traced r (Referenced Schema)]
+tracedOneOf sch = _schemaOneOf (extract sch) <&> \xs ->
+    [ traced (ask sch >>> step (OneOfStep i)) x | (i, x) <- zip [0..] xs ]
+
+tracedItems :: Traced r Schema -> Maybe (Either (Traced r (Referenced Schema)) [Traced r (Referenced Schema)])
+tracedItems sch = _schemaItems (extract sch) <&> \case
+  OpenApiItemsObject x -> Left $ traced (ask sch >>> step ItemsObjectStep) x
+  OpenApiItemsArray xs -> Right
+    [ traced (ask sch >>> step (ItemsArrayStep i)) x | (i, x) <- zip [0..] xs ]
+
+tracedAdditionalProperties :: Traced r Schema -> Maybe (Either Bool (Traced r (Referenced Schema)))
+tracedAdditionalProperties sch = _schemaAdditionalProperties (extract sch) <&> \case
+  AdditionalPropertiesAllowed b -> Left b
+  AdditionalPropertiesSchema x -> Right $ traced (ask sch >>> step AdditionalPropertiesStep) x
+
+tracedProperties :: Traced r Schema -> IOHM.InsOrdHashMap Text (Traced r (Referenced Schema))
+tracedProperties sch = IOHM.mapWithKey (\k -> traced (ask sch >>> step (PropertiesStep k)))
+  $ _schemaProperties $ extract sch
 
 -- | Turn a schema into a tuple of 'JsonFormula's that describes the condition
 -- for every possible type of a JSON value. The conditions are independent, and
@@ -368,36 +399,33 @@ processRefSchema x = do
 processSchema
   :: Traced OpenApi Schema
   -> ProcessM (ForeachType (JsonFormula OpenApi))
-processSchema (Traced t Schema{..}) = do
+processSchema sch@(extract -> Schema{..}) = do
+  let
+    singletonFormula :: Typeable t => Step Schema (Condition t) -> Condition t -> JsonFormula OpenApi t
+    singletonFormula t f = SingleConjunct [traced (ask sch >>> step t) f]
 
-  allClauses <- case _schemaAllOf of
+  allClauses <- case tracedAllOf sch of
     Nothing -> pure []
-    Just [] -> [] <$ warn t (InvalidSchema "no items in allOf")
+    Just [] -> [] <$ warn sch (InvalidSchema "no items in allOf")
-    Just xs -> sequence
+    Just xs -> mapM processRefSchema xs
-      [ processRefSchema (Traced (t `Snoc` AllOfStep i) rs)
-      | (i, rs) <- zip [0..] xs ]
 
-  anyClause <- case _schemaAnyOf of
+  anyClause <- case tracedAnyOf sch of
     Nothing -> pure top
-    Just [] -> bottom <$ warn t (InvalidSchema "no items in anyOf")
+    Just [] -> bottom <$ warn sch (InvalidSchema "no items in anyOf")
-    Just xs -> joins <$> sequence
+    Just xs -> joins <$> mapM processRefSchema xs
-      [ processRefSchema (Traced (t `Snoc` AnyOfStep i) rs)
-      | (i, rs) <- zip [0..] xs ]
 
-  oneClause <- case _schemaOneOf of
+  oneClause <- case tracedOneOf sch of
     Nothing -> pure top
-    Just [] -> bottom <$ warn t (InvalidSchema "no items in oneOf")
+    Just [] -> bottom <$ warn sch (InvalidSchema "no items in oneOf")
     Just xs -> do
       checkOneOfDisjoint xs >>= \case
         True -> pure ()
-        False -> warn t (NotSupported "Could not determine that oneOf branches are disjoint")
+        False -> warn sch (NotSupported "Could not determine that oneOf branches are disjoint")
-      joins <$> sequence
+      joins <$> mapM processRefSchema xs
-        [ processRefSchema (Traced (t `Snoc` OneOfStep i) rs)
-        | (i, rs) <- zip [0..] xs ]
 
   case _schemaNot of
     Nothing -> pure ()
-    Just _ -> warn t (NotSupported "not clause is unsupported")
+    Just _ -> warn sch (NotSupported "not clause is unsupported")
 
   let
     typeClause = case _schemaType of
@@ -409,7 +437,7 @@ processSchema (Traced t Schema{..}) = do
       Just OpenApiNumber -> bottom
         { forBoolean = top }
       Just OpenApiInteger -> bottom
-        { forNumber = singletonFormula (t `Snoc` IntegerType) $ MultipleOf 1 }
+        { forNumber = singletonFormula IntegerType $ MultipleOf 1 }
       Just OpenApiString -> bottom
         { forString = top }
       Just OpenApiArray -> bottom
@@ -419,27 +447,27 @@ processSchema (Traced t Schema{..}) = do
 
   let
     valueEnum A.Null = bottom
-      { forNull = singletonFormula (t `Snoc` EnumField) $ Exactly TNull }
+      { forNull = singletonFormula EnumField $ Exactly TNull }
     valueEnum (A.Bool b) = bottom
-      { forBoolean = singletonFormula (t `Snoc` EnumField) $ Exactly $ TBool b }
+      { forBoolean = singletonFormula EnumField $ Exactly $ TBool b }
     valueEnum (A.Number n) = bottom
-      { forNumber = singletonFormula (t `Snoc` EnumField) $ Exactly $ TNumber n }
+      { forNumber = singletonFormula EnumField $ Exactly $ TNumber n }
     valueEnum (A.String s) = bottom
-      { forString = singletonFormula (t `Snoc` EnumField) $ Exactly $ TString s }
+      { forString = singletonFormula EnumField $ Exactly $ TString s }
     valueEnum (A.Array a) = bottom
-      { forArray = singletonFormula (t `Snoc` EnumField) $ Exactly $ TArray a }
+      { forArray = singletonFormula EnumField $ Exactly $ TArray a }
     valueEnum (A.Object o) = bottom
-      { forObject = singletonFormula (t `Snoc` EnumField) $ Exactly $ TObject o }
+      { forObject = singletonFormula EnumField $ Exactly $ TObject o }
   enumClause <- case _schemaEnum of
     Nothing -> pure top
-    Just [] -> bottom <$ warn t (InvalidSchema "no items in enum")
+    Just [] -> bottom <$ warn sch (InvalidSchema "no items in enum")
     Just xs -> pure $ joins (valueEnum <$> xs)
 
   let
     maximumClause = case _schemaMaximum of
       Nothing -> top
       Just n -> top
-        { forNumber = singletonFormula (t `Snoc` MaximumFields) $ Maximum $
+        { forNumber = singletonFormula MaximumFields $ Maximum $
           case _schemaExclusiveMaximum of
             Just True -> Exclusive n
             _ -> Inclusive n }
@@ -447,7 +475,7 @@ processSchema (Traced t Schema{..}) = do
     minimumClause = case _schemaMinimum of
       Nothing -> top
       Just n -> top
-        { forNumber = singletonFormula (t `Snoc` MinimumFields) $ Minimum $ Down $
+        { forNumber = singletonFormula MinimumFields $ Minimum $ Down $
           case _schemaExclusiveMinimum of
             Just True -> Exclusive $ Down n
             _ -> Inclusive $ Down n }
@@ -455,72 +483,68 @@ processSchema (Traced t Schema{..}) = do
     multipleOfClause = case _schemaMultipleOf of
       Nothing -> top
       Just n -> top
-        { forNumber = singletonFormula (t `Snoc` MultipleOfField) $ MultipleOf n }
+        { forNumber = singletonFormula MultipleOfField $ MultipleOf n }
 
   formatClause <- case _schemaFormat of
     Nothing -> pure top
     Just f | f `elem` ["int32", "int64", "float", "double"] -> pure top
-      { forNumber = singletonFormula (t `Snoc` FormatField) $ NumberFormat f }
+      { forNumber = singletonFormula FormatField $ NumberFormat f }
     Just f | f `elem` ["byte", "binary", "date", "date-time", "password"] -> pure top
-      { forString = singletonFormula (t `Snoc` FormatField) $ StringFormat f }
+      { forString = singletonFormula FormatField $ StringFormat f }
-    Just f -> top <$ warn t (NotSupported $ "Unknown format: " <> f)
+    Just f -> top <$ warn sch (NotSupported $ "Unknown format: " <> f)
 
   let
     maxLengthClause = case _schemaMaxLength of
       Nothing -> top
       Just n -> top
-        { forString = singletonFormula (t `Snoc` MaxLengthField) $ MaxLength n }
+        { forString = singletonFormula MaxLengthField $ MaxLength n }
 
     minLengthClause = case _schemaMinLength of
       Nothing -> top
       Just n -> top
-        { forString = singletonFormula (t `Snoc` MinLengthField) $ MinLength n }
+        { forString = singletonFormula MinLengthField $ MinLength n }
 
     patternClause = case _schemaPattern of
       Nothing -> top
       Just p -> top
-        { forString = singletonFormula (t `Snoc` PatternField) $ Pattern p }
+        { forString = singletonFormula PatternField $ Pattern p }
 
-  itemsClause <- case _schemaItems of
+  itemsClause <- case tracedItems sch of
     Nothing -> pure top
-    Just (OpenApiItemsObject rs) -> do
+    Just (Left rs) -> do
-      let trs = Traced (t `Snoc` ItemsStep) rs
+      f <- processRefSchema rs
-      f <- processRefSchema trs
+      pure top { forArray = singletonFormula ItemsField $ Items f rs }
-      pure top { forArray = singletonFormula (t `Snoc` ItemsField) $ Items f trs }
+    Just (Right _) -> top <$ warn sch (NotSupported "array in items is not supported")
-    Just (OpenApiItemsArray _) -> top <$ warn t (NotSupported "array in items is not supported")
 
   let
     maxItemsClause = case _schemaMaxItems of
       Nothing -> top
       Just n -> top
-        { forArray = singletonFormula (t `Snoc` MaxItemsField) $ MaxItems n }
+        { forArray = singletonFormula MaxItemsField $ MaxItems n }
 
     minItemsClause = case _schemaMinItems of
       Nothing -> top
       Just n -> top
-        { forArray = singletonFormula (t `Snoc` MinItemsField) $ MinItems n }
+        { forArray = singletonFormula MinItemsField $ MinItems n }
 
     uniqueItemsClause = case _schemaUniqueItems of
       Just True -> top
-        { forArray = singletonFormula (t `Snoc` UniqueItemsField) UniqueItems }
+        { forArray = singletonFormula UniqueItemsField UniqueItems }
       _ -> top
 
-  (addProps, addPropSchema) <- case _schemaAdditionalProperties of
+  (addProps, addPropSchema) <- case tracedAdditionalProperties sch of
-    Just (AdditionalPropertiesSchema rs) -> do
+    Just (Right rs) -> (,Just rs) <$> processRefSchema rs
-      let trs = Traced (t `Snoc` AdditionalPropertiesStep) rs
+    Just (Left False) -> pure (bottom, Nothing)
-      (,Just trs) <$> processRefSchema trs
+    _ -> pure (top, Just $ traced (ask sch `Snoc` AdditionalPropertiesStep) $ Inline mempty)
-    Just (AdditionalPropertiesAllowed False) -> pure (bottom, Nothing)
-    _ -> pure (top, Just $ Traced (t `Snoc` AdditionalPropertiesStep) $ Inline mempty)
   propList <- forM (S.toList . S.fromList $ IOHM.keys _schemaProperties <> _schemaRequired) $ \k -> do
-    (f, sch) <- case IOHM.lookup k _schemaProperties of
+    (f, psch) <- case IOHM.lookup k $ tracedProperties sch of
-      Just rs -> do
+      Just rs -> (,rs) <$> processRefSchema rs
-        let trs = Traced (t `Snoc` PropertiesStep k) rs
+      Nothing -> let fakeSchema = traced (ask sch `Snoc` AdditionalPropertiesStep) $ Inline mempty
-        (,trs) <$> processRefSchema trs
-      Nothing -> pure (addProps, fromMaybe (Traced (t `Snoc` AdditionalPropertiesStep) $ Inline mempty) addPropSchema)
       -- The mempty here is incorrect, but if addPropSchema was Nothing, then
       -- addProps is bottom, and k is in _schemaRequired. We handle this situation
       -- below and short-circuit the entire Properties condition to bottom
-    pure (k, Property (k `elem` _schemaRequired) f sch)
+        in pure (addProps, fromMaybe fakeSchema addPropSchema)
+    pure (k, Property (k `elem` _schemaRequired) f psch)
   let
     allBottom f = getAll $ foldType $ \ty -> case ty f of
       BottomFormula -> All True
@@ -537,21 +561,21 @@ processSchema (Traced t Schema{..}) = do
       = top -- if all fields are optional and have trivial schemata
       | otherwise
       = top
-        { forObject = singletonFormula (t `Snoc` PropertiesFields) $ Properties propMap addProps addPropSchema }
+        { forObject = singletonFormula PropertiesFields $ Properties propMap addProps addPropSchema }
 
     maxPropertiesClause = case _schemaMaxProperties of
       Nothing -> top
       Just n -> top
-        { forObject = singletonFormula (t `Snoc` MaxPropertiesField) $ MaxProperties n }
+        { forObject = singletonFormula MaxPropertiesField $ MaxProperties n }
 
     minPropertiesClause = case _schemaMinProperties of
       Nothing -> top
       Just n -> top
-        { forObject = singletonFormula (t `Snoc` MinPropertiesField) $ MinProperties n }
+        { forObject = singletonFormula MinPropertiesField $ MinProperties n }
 
     nullableClause
       | Just True <- _schemaNullable = bottom
-        { forNull = singletonFormula (t `Snoc` NullableField) $ Exactly TNull }
+        { forNull = singletonFormula NullableField $ Exactly TNull }
       | otherwise = bottom
 
   pure $ nullableClause \/ meets (allClauses <>
@@ -561,7 +585,7 @@ processSchema (Traced t Schema{..}) = do
     , uniqueItemsClause, propertiesClause, maxPropertiesClause, minPropertiesClause])
 {- TODO: ReadOnly/WriteOnly -}
 
-checkOneOfDisjoint :: [Referenced Schema] -> ProcessM Bool
+checkOneOfDisjoint :: [Traced OpenApi (Referenced Schema)] -> ProcessM Bool
 checkOneOfDisjoint = const $ pure True -- TODO
 
 schemaToFormula
@@ -575,7 +599,7 @@ checkFormulas
   => HList xs
   -> Trace OpenApi Schema
   -> ProdCons (ForeachType (JsonFormula OpenApi), T.TracePrefixTree SubtreeCheckIssue OpenApi)
-  -> CompatFormula Schema ()
+  -> CompatFormula ()
 checkFormulas env tr (ProdCons (fp, ep) (fc, ec)) =
   case T.toList ep ++ T.toList ec of
     issues@(_:_) -> F.for_ issues $ \(AnItem t (SubtreeCheckIssue e)) -> issueAtTrace t e
@@ -613,13 +637,13 @@ checkFormulas env tr (ProdCons (fp, ep) (fc, ec)) =
           (DNF pss, SingleConjunct cs) -> F.for_ pss $ \(Conjunct ps) -> do
             F.for_ cs $ checkImplication env ps -- avoid disjuntion if there's only one conjunct
           (DNF pss, DNF css) -> F.for_ pss $ \(Conjunct ps) -> do
-            anyOfM tr (SubtreeCheckIssue $ NoMatchingCondition $ SomeCondition . getTraced <$> ps)
+            anyOfM tr (NoMatchingCondition $ SomeCondition <$> ps)
               [F.for_ cs $ checkImplication env ps | Conjunct cs <- S.toList css]
 
 checkContradiction
   :: Trace OpenApi Schema
   -> [Traced OpenApi (Condition t)]
-  -> CompatFormula s ()
+  -> CompatFormula ()
 checkContradiction tr _ = issueAtTrace tr NoContradiction -- TODO
 
 checkImplication
@@ -627,96 +651,93 @@ checkImplication
   => HList xs
   -> [Traced OpenApi (Condition t)]
   -> Traced OpenApi (Condition t)
-  -> CompatFormula s ()
+  -> CompatFormula ()
-checkImplication env prods (Traced t cons) = case findExactly prods of
+checkImplication env prods cons = case findExactly prods of
   Just e
-    | all (satisfiesTyped e) (getTraced <$> prods) ->
+    | all (satisfiesTyped e) (extract <$> prods) ->
-      if satisfiesTyped e cons then pure ()
+      if satisfiesTyped e $ extract cons then pure ()
-        else issueAtTrace t (EnumDoesntSatisfy e)
+        else issueAt cons (EnumDoesntSatisfy e)
     | otherwise -> pure () -- vacuously true
-  Nothing -> case cons of
+  Nothing -> case extract cons of
     -- the above code didn't catch it, so there's no Exactly condition on the lhs
-    Exactly e -> issueAtTrace t (NoMatchingEnum e)
+    Exactly e -> issueAt cons (NoMatchingEnum e)
     Maximum m -> case findRelevant min (\case Maximum m' -> Just m'; _ -> Nothing) prods of
       Just m' -> if m' <= m then pure ()
-        else issueAtTrace t (MatchingMaximumWeak m m')
+        else issueAt cons (MatchingMaximumWeak m m')
-      Nothing -> issueAtTrace t (NoMatchingMaximum m)
+      Nothing -> issueAt cons (NoMatchingMaximum m)
     Minimum m -> case findRelevant max (\case Minimum m' -> Just m'; _ -> Nothing) prods of
       Just m' -> if m' >= m then pure ()
-        else issueAtTrace t (MatchingMinimumWeak (coerce m) (coerce m'))
+        else issueAt cons (MatchingMinimumWeak (coerce m) (coerce m'))
-      Nothing -> issueAtTrace t (NoMatchingMinimum (coerce m))
+      Nothing -> issueAt cons (NoMatchingMinimum (coerce m))
     MultipleOf m -> case findRelevant lcmScientific (\case MultipleOf m' -> Just m'; _ -> Nothing) prods of
       Just m' -> if lcmScientific m m' == m' then pure ()
-        else issueAtTrace t (MatchingMultipleOfWeak m m')
+        else issueAt cons (MatchingMultipleOfWeak m m')
-      Nothing -> issueAtTrace t (NoMatchingMultipleOf m)
+      Nothing -> issueAt cons (NoMatchingMultipleOf m)
-    NumberFormat f -> if any (\case NumberFormat f' -> f == f'; _ -> False) $ getTraced <$> prods
+    NumberFormat f -> if any (\case NumberFormat f' -> f == f'; _ -> False) $ extract <$> prods
-      then pure () else issueAtTrace t (NoMatchingFormat f)
+      then pure () else issueAt cons (NoMatchingFormat f)
     MaxLength m -> case findRelevant min (\case MaxLength m' -> Just m'; _ -> Nothing) prods of
       Just m' -> if m' <= m then pure ()
-        else issueAtTrace t (MatchingMaxLengthWeak m m')
+        else issueAt cons (MatchingMaxLengthWeak m m')
-      Nothing -> issueAtTrace t (NoMatchingMaxLength m)
+      Nothing -> issueAt cons (NoMatchingMaxLength m)
     MinLength m -> case findRelevant max (\case MinLength m' -> Just m'; _ -> Nothing) prods of
       Just m' -> if m' >= m then pure ()
-        else issueAtTrace t (MatchingMinLengthWeak m m')
+        else issueAt cons (MatchingMinLengthWeak m m')
-      Nothing -> issueAtTrace t (NoMatchingMinLength m)
+      Nothing -> issueAt cons (NoMatchingMinLength m)
-    Pattern p -> if any (\case Pattern p' -> p == p'; _ -> False) $ getTraced <$> prods
+    Pattern p -> if any (\case Pattern p' -> p == p'; _ -> False) $ extract <$> prods
-      then pure () else issueAtTrace t (NoMatchingPattern p)
+      then pure () else issueAt cons (NoMatchingPattern p)
-    StringFormat f -> if any (\case StringFormat f' -> f == f'; _ -> False) $ getTraced <$> prods
+    StringFormat f -> if any (\case StringFormat f' -> f == f'; _ -> False) $ extract <$> prods
-      then pure () else issueAtTrace t (NoMatchingFormat f)
+      then pure () else issueAt cons (NoMatchingFormat f)
-    Items _ (Traced t' cons') -> case findRelevant (<>) (\case Items _ rs -> Just (rs NE.:| []); _ -> Nothing) prods of
+    Items _ cons' -> case findRelevant (<>) (\case Items _ rs -> Just (rs NE.:| []); _ -> Nothing) prods of
-      Just (rs NE.:| []) -> localTrace' (ProdCons (getTrace rs) t') $ checkCompatibility env $ ProdCons (getTraced rs) cons'
+      Just (rs NE.:| []) -> checkCompatibility env $ ProdCons rs cons'
       Just rs -> do
-        let sch = Inline mempty { _schemaAllOf = Just . NE.toList $ getTraced <$> rs }
+        let sch = Inline mempty { _schemaAllOf = Just . NE.toList $ extract <$> rs }
-        localTrace' (pure t' {- TODO: what? -}) $ checkCompatibility env $ ProdCons sch cons'
+        checkCompatibility env $ ProdCons (traced (ask $ NE.head rs) sch) cons' -- TODO: bad trace
-      Nothing -> issueAtTrace t NoMatchingItems
+      Nothing -> issueAt cons NoMatchingItems
     MaxItems m -> case findRelevant min (\case MaxItems m' -> Just m'; _ -> Nothing) prods of
       Just m' -> if m' <= m then pure ()
-        else issueAtTrace t (MatchingMaxItemsWeak m m')
+        else issueAt cons (MatchingMaxItemsWeak m m')
-      Nothing -> issueAtTrace t (NoMatchingMaxItems m)
+      Nothing -> issueAt cons (NoMatchingMaxItems m)
     MinItems m -> case findRelevant max (\case MinItems m' -> Just m'; _ -> Nothing) prods of
       Just m' -> if m' >= m then pure ()
-        else issueAtTrace t (MatchingMinItemsWeak m m')
+        else issueAt cons (MatchingMinItemsWeak m m')
-      Nothing -> issueAtTrace t (NoMatchingMinItems m)
+      Nothing -> issueAt cons (NoMatchingMinItems m)
-    UniqueItems -> if any ((== UniqueItems) . getTraced) prods then pure ()
+    UniqueItems -> if any (== UniqueItems) $ extract <$> prods then pure ()
-      else issueAtTrace t NoMatchingUniqueItems
+      else issueAt cons NoMatchingUniqueItems
     Properties props _ madd -> case findRelevant (<>) (\case Properties props' _ madd' -> Just $ (props', madd') NE.:| []; _ -> Nothing) prods of
       Just ((props', madd') NE.:| []) -> do
         F.for_ (S.fromList $ M.keys props <> M.keys props') $ \k -> do
-          let
+          let go sch sch' = checkCompatibility env (ProdCons sch sch')
-            go sch' sch = let schs = ProdCons sch' sch
-              in localTrace' (getTrace <$> schs) $ checkCompatibility env $ getTraced <$> schs
           case (M.lookup k props', madd', M.lookup k props, madd) of
             (Nothing, Nothing, _, _) -> pure () -- vacuously
-            (_, _, Nothing, Nothing) -> issueAtTrace t (UnexpectedProperty k)
+            (_, _, Nothing, Nothing) -> issueAt cons (UnexpectedProperty k)
             (Just p', _, Just p, _) -> go (propRefSchema p') (propRefSchema p)
             (Nothing, Just add', Just p, _) -> go add' (propRefSchema p)
             (Just p', _, Nothing, Just add) -> go (propRefSchema p') add
             (Nothing, Just _, Nothing, Just _) -> pure ()
           case (maybe False propRequired $ M.lookup k props', maybe False propRequired $ M.lookup k props) of
-            (False, True) -> issueAtTrace t (PropertyNowRequired k)
+            (False, True) -> issueAt cons (PropertyNowRequired k)
             _ -> pure ()
           pure ()
         case (madd', madd) of
           (Nothing, _) -> pure () -- vacuously
-          (_, Nothing) -> issueAtTrace t NoAdditionalProperties
+          (_, Nothing) -> issueAt cons NoAdditionalProperties
-          (Just add', Just add) -> let schs = ProdCons add' add
+          (Just add', Just add) -> checkCompatibility env (ProdCons add' add)
-            in localTrace' (getTrace <$> schs) $ checkCompatibility env $ getTraced <$> schs
         pure ()
-      Nothing -> issueAtTrace t NoMatchingProperties
+      Nothing -> issueAt cons NoMatchingProperties
     MaxProperties m -> case findRelevant min (\case MaxProperties m' -> Just m'; _ -> Nothing) prods of
       Just m' -> if m' <= m then pure ()
-        else issueAtTrace t (MatchingMaxPropertiesWeak m m')
+        else issueAt cons (MatchingMaxPropertiesWeak m m')
-      Nothing -> issueAtTrace t (NoMatchingMaxProperties m)
+      Nothing -> issueAt cons (NoMatchingMaxProperties m)
     MinProperties m -> case findRelevant max (\case MinProperties m' -> Just m'; _ -> Nothing) prods of
       Just m' -> if m' >= m then pure ()
-        else issueAtTrace t (MatchingMinPropertiesWeak m m')
+        else issueAt cons (MatchingMinPropertiesWeak m m')
-      Nothing -> issueAtTrace t (NoMatchingMinProperties m)
+      Nothing -> issueAt cons (NoMatchingMinProperties m)
   where
-    findExactly (Traced _ (Exactly x):_) = Just x
+    findExactly ((extract -> Exactly x):_) = Just x
     findExactly (_:xs) = findExactly xs
     findExactly [] = Nothing
-    findRelevant combine extract
+    findRelevant combine extr
-      = fmap (foldr1 combine) . NE.nonEmpty . mapMaybe (extract . getTraced)
+      = fmap (foldr1 combine) . NE.nonEmpty . mapMaybe (extr . extract)
     lcmScientific (toRational -> a) (toRational -> b)
       = fromRational $ lcm (numerator a) (numerator b) % gcd (denominator a) (denominator b)
 
@@ -753,9 +774,7 @@ instance Typeable t => Subtree (Condition t) where
     deriving stock (Eq, Ord, Show)
   type CheckEnv (Condition t) = CheckEnv Schema
   normalizeTrace = undefined
-  checkCompatibility env conds = withTrace $ \traces -> do
+  checkCompatibility env pc = checkImplication env [producer pc] (consumer pc)
-    case Traced <$> traces <*> conds of
-      ProdCons prod cons -> checkImplication env [prod] cons
 
 instance Subtree Schema where
   data CheckIssue Schema
@@ -765,18 +784,16 @@ instance Subtree Schema where
     | NoContradiction
     deriving stock (Eq, Ord, Show)
   type CheckEnv Schema = '[ProdCons (Definitions Schema)]
-  checkCompatibility env schs = withTrace $ \traces -> do
+  checkCompatibility env schs = do
     let defs = getH env
-    checkFormulas env (producer traces) $ schemaToFormula <$> defs <*> (Traced <$> traces <*> schs)
+    checkFormulas env (ask $ producer schs) $ schemaToFormula <$> defs <*> schs
 
 instance Subtree (Referenced Schema) where
   data CheckIssue (Referenced Schema)
     deriving stock (Eq, Ord, Show)
   type CheckEnv (Referenced Schema) = CheckEnv Schema
-  checkCompatibility env refs = withTrace $ \traces -> do
+  checkCompatibility env refs = do
     let
       defs = getH env
       schs = dereference <$> defs <*> refs
-      schs' = retrace <$> traces <*> schs
+    checkFormulas env (ask $ producer schs) $ schemaToFormula <$> defs <*> schs
-    localTrace (getTrace <$> schs) $ do
-      checkFormulas env (producer $ getTrace <$> schs') $ schemaToFormula <$> defs <*> schs'

src/OpenAPI/Checker/Validate/SecurityRequirement.hs

@@ -1,9 +1,8 @@
 {-# OPTIONS_GHC -Wno-orphans #-}
 
 module OpenAPI.Checker.Validate.SecurityRequirement
-  (
+  ( CheckIssue (..)
-  )
+  ) where
-where
 
 import Data.OpenApi
 import OpenAPI.Checker.Subtree
@@ -14,5 +13,6 @@ instance Subtree SecurityRequirement where
       '[ ProdCons (Definitions SecurityScheme)
        ]
   data CheckIssue SecurityRequirement
+    = SecurityRequirementNotMet
     deriving (Eq, Ord, Show)
   checkCompatibility = undefined

src/OpenAPI/Checker/Validate/Server.hs

@@ -1,9 +1,8 @@
 {-# OPTIONS_GHC -Wno-orphans #-}
 
 module OpenAPI.Checker.Validate.Server
-  (
+  ( CheckIssue(..)
-  )
+  ) where
-where
 
 import Data.OpenApi
 import OpenAPI.Checker.Subtree
@@ -11,5 +10,6 @@ import OpenAPI.Checker.Subtree
 instance Subtree Server where
   type CheckEnv Server = '[]
   data CheckIssue Server
+    = ServerNotConsumed
     deriving (Eq, Ord, Show)
   checkCompatibility = undefined

src/OpenAPI/Checker/Validate/Sums.hs

@@ -10,19 +10,17 @@ import OpenAPI.Checker.Trace
 
 
 checkSums
-  :: forall k root t
+  :: forall k r t
-  .  (Ord k, Subtree root)
+  .  (Ord k, Subtree t)
-  => (k -> CheckIssue root)
+  => (k -> CheckIssue t)
-  -> (k -> ProdCons t -> CompatFormula t ())
+  -> (k -> ProdCons (Traced r t) -> CompatFormula' SubtreeCheckIssue r ())
-  -> ProdCons (Map k (Traced root t))
+  -> ProdCons (Map k (Traced r t))
-  -> CompatFormula root ()
+  -> CompatFormula' SubtreeCheckIssue r ()
 checkSums noElt check (ProdCons p c) = for_ (M.toList p) $ \(key, prodElt) ->
   case M.lookup key c of
-    Nothing -> issueAt consumer $ noElt key
+    Nothing -> issueAt prodElt $ noElt key
     Just consElt ->
       let
-        sumElts :: ProdCons (Traced root t)
+        sumElts :: ProdCons (Traced r t)
         sumElts = ProdCons prodElt consElt
-        trace = getTrace <$> sumElts
+      in check key sumElts
-        elements = getTraced <$> sumElts
-      in localTrace trace $ check key elements

test/Spec/Golden/TraceTree.hs

@@ -7,6 +7,7 @@ import Control.Category
 import Data.HList
 import qualified Data.Yaml as Yaml
 import OpenAPI.Checker.Subtree
+import OpenAPI.Checker.Trace
 import OpenAPI.Checker.Validate.OpenApi ()
 import Spec.Golden.Extra
 import Test.Tasty (TestTree)
@@ -20,4 +21,4 @@ tests =
     "trace-tree.yaml"
     ("a.yaml", "b.yaml")
     Yaml.decodeFileThrow
-    (runCompatFormula (pure id) . checkCompatibility HNil . uncurry ProdCons)
+    (runCompatFormula . checkCompatibility HNil . fmap (traced Root) . uncurry ProdCons)

test/golden/common/maximum-lowered/trace-tree.yaml

@@ -1,7 +1,7 @@
 Left:
   OpenApiPathsStep:
     MatchedPathStep "/test":
-      PostStep:
+      OperationMethodStep PostMethod:
         OperationRequestBodyStep:
           InlineStep:
             RequestMediaTypeObject application/json:

test/golden/common/pathItem/operation/parameters/allowEmptyValue/reset/trace-tree.yaml

@@ -1,6 +1,6 @@
 Left:
   OpenApiPathsStep:
     MatchedPathStep "/test":
-      PostStep:
+      OperationMethodStep PostMethod:
-        OperationParamsStep:
+        OperationParamsStep 0:
           InlineStep: ParamEmptinessIncompatible

test/golden/common/pathItem/operation/parameters/change/trace-tree.yaml

@@ -1,8 +1,8 @@
 Left:
   OpenApiPathsStep:
     MatchedPathStep "/test":
-      PostStep:
+      OperationMethodStep PostMethod:
-        OperationParamsStep:
+        OperationParamsStep 0:
           InlineStep:
             ParamSchema:
               InlineStep: NoContradiction

test/golden/common/pathItem/operation/parameters/required/set/trace-tree.yaml

@@ -1,6 +1,6 @@
 Left:
   OpenApiPathsStep:
     MatchedPathStep "/test":
-      PostStep:
+      OperationMethodStep PostMethod:
-        OperationParamsStep:
+        OperationParamsStep 0:
           InlineStep: ParamRequired

test/golden/common/pathItem/operation/parameters/required/true/add/trace-tree.yaml

@@ -1,4 +1,6 @@
 Left:
   OpenApiPathsStep:
     MatchedPathStep "/test":
-      PostStep: ParamNotMatched ParamQuery "test2"
+      OperationMethodStep PostMethod:
+        OperationParamsStep 1:
+          InlineStep: ParamNotMatched "test2"

test/golden/common/pathItem/operation/requestBody/mediaTypeObject/change/trace-tree.yaml

@@ -1,7 +1,7 @@
 Left:
   OpenApiPathsStep:
     MatchedPathStep "/test":
-      PostStep:
+      OperationMethodStep PostMethod:
         OperationRequestBodyStep:
           InlineStep:
             RequestMediaTypeObject application/json:

test/golden/common/pathItem/operation/requestBody/mediaTypeObject/del/trace-tree.yaml

@@ -1,6 +1,7 @@
 Left:
   OpenApiPathsStep:
     MatchedPathStep "/test":
-      PostStep:
+      OperationMethodStep PostMethod:
         OperationRequestBodyStep:
-          InlineStep: RequestMediaTypeNotFound application/x-www-form-urlencoded
+          InlineStep:
+            RequestMediaTypeObject application/x-www-form-urlencoded: RequestMediaTypeNotFound

test/golden/common/pathItem/operation/requestBody/required/set/trace-tree.yaml

@@ -1,6 +1,6 @@
 Left:
   OpenApiPathsStep:
     MatchedPathStep "/test":
-      PostStep:
+      OperationMethodStep PostMethod:
         OperationRequestBodyStep:
           InlineStep: RequestBodyRequired

test/golden/common/pathItem/operation/responses/add/trace-tree.yaml

@@ -1,5 +1,7 @@
 Left:
   OpenApiPathsStep:
     MatchedPathStep "/test":
-      PostStep:
+      OperationMethodStep PostMethod:
-        OperationResponsesStep: ResponseCodeNotFound 500
+        OperationResponsesStep:
+          ResponseCodeStep 500:
+            InlineStep: ResponseCodeNotFound

test/golden/common/pathItem/operation/responses/change/headers/mandatory/del/trace-tree.yaml

@@ -1,7 +1,9 @@
 Left:
   OpenApiPathsStep:
     MatchedPathStep "/test":
-      PostStep:
+      OperationMethodStep PostMethod:
         OperationResponsesStep:
           ResponseCodeStep 200:
-            InlineStep: ResponseHeaderMissing "Test2"
+            InlineStep:
+              ResponseHeader "Test2":
+                InlineStep: ResponseHeaderMissing

test/golden/common/pathItem/operation/responses/change/mediaTypeObject/add/trace-tree.yaml

@@ -1,7 +1,8 @@
 Left:
   OpenApiPathsStep:
     MatchedPathStep "/test":
-      PostStep:
+      OperationMethodStep PostMethod:
         OperationResponsesStep:
           ResponseCodeStep 200:
-            InlineStep: ResponseMediaTypeMissing application/x-www-form-urlencoded
+            InlineStep:
+              ResponseMediaObject application/x-www-form-urlencoded: ResponseMediaTypeMissing

test/golden/common/pathItem/operation/responses/change/mediaTypeObject/change/trace-tree.yaml

@@ -1,7 +1,7 @@
 Left:
   OpenApiPathsStep:
     MatchedPathStep "/test":
-      PostStep:
+      OperationMethodStep PostMethod:
         OperationResponsesStep:
           ResponseCodeStep 200:
             InlineStep:

test/golden/common/property-removed/trace-tree.yaml

@@ -1,7 +1,7 @@
 Left:
   OpenApiPathsStep:
     MatchedPathStep "/test":
-      PostStep:
+      OperationMethodStep PostMethod:
         OperationResponsesStep:
           ResponseCodeStep 200:
             InlineStep:

test/golden/common/property-required/trace-tree.yaml

@@ -1,7 +1,7 @@
 Left:
   OpenApiPathsStep:
     MatchedPathStep "/test":
-      PostStep:
+      OperationMethodStep PostMethod:
         OperationRequestBodyStep:
           InlineStep:
             RequestMediaTypeObject application/json: