Traces (#50)

* Implement internal vs external traces

* Fixup tests

* Move some errors around

* ToBehavior -> SubtreeLevel

* minor fixes

* Fixed server

* integrated anyOfSubtreeAt into anyOfAt

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

openapi-diff.cabal

@@ -98,15 +98,16 @@ library
   import:              common-options
   hs-source-dirs:      src
   exposed-modules:  Data.HList
+                  , OpenAPI.Checker.Behavior
                   , OpenAPI.Checker.Formula
                   , OpenAPI.Checker.Memo
                   , OpenAPI.Checker.Options
                   , OpenAPI.Checker.Orphans
+                  , OpenAPI.Checker.Paths
+                  , OpenAPI.Checker.PathsPrefixTree
                   , OpenAPI.Checker.References
                   , OpenAPI.Checker.Run
                   , OpenAPI.Checker.Subtree
-                  , OpenAPI.Checker.Trace
-                  , OpenAPI.Checker.TracePrefixTree
                   , OpenAPI.Checker.Validate.MediaTypeObject
                   , OpenAPI.Checker.Validate.OpenApi
                   , OpenAPI.Checker.Validate.Operation

src/OpenAPI/Checker/Behavior.hs

@@ -0,0 +1,53 @@
+module OpenAPI.Checker.Behavior
+  ( BehaviorLevel (..)
+  , Behavable (..)
+  , Issuable (..)
+  , Behavior
+  , AnIssue (..)
+  ) where
+
+import Data.Aeson
+import Data.Kind
+import Data.Text as T
+import OpenAPI.Checker.Paths
+
+-- | Kind
+data BehaviorLevel
+  = APILevel
+  | ServerLevel
+  | SecurityRequirementLevel
+  | PathLevel
+  | OperationLevel
+  | PathFragmentLevel
+  | RequestLevel
+  | ResponseLevel
+  | HeaderLevel
+  | -- | either request or response data
+    PayloadLevel
+  | SchemaLevel
+  | TypedSchemaLevel
+
+class (Ord (Behave a b), Show (Behave a b))
+  => Behavable (a :: BehaviorLevel) (b :: BehaviorLevel) where
+  data Behave a b
+
+class (Ord (Issue l), Show (Issue l)) => Issuable (l :: BehaviorLevel) where
+  data Issue l :: Type
+  describeIssue :: Issue l -> Text
+  describeIssue = T.pack . show -- TODO: remove this default
+  issueIsUnsupported :: Issue l -> Bool
+
+-- | A set of interactions having common unifying features
+type Behavior = Paths Behave 'APILevel
+
+instance Issuable l => ToJSON (Issue l) where
+  toJSON = toJSON . describeIssue
+
+data AnIssue (l :: BehaviorLevel) where
+  AnIssue :: Issuable l => Issue l -> AnIssue l
+
+deriving stock instance Eq (AnIssue l)
+deriving stock instance Ord (AnIssue l)
+
+instance ToJSON (AnIssue l) where
+  toJSON (AnIssue issue) = toJSON issue

src/OpenAPI/Checker/Formula.hs

@@ -12,8 +12,8 @@ module OpenAPI.Checker.Formula
 import Data.Kind
 import Data.Monoid
 import qualified Data.List.NonEmpty as NE
-import OpenAPI.Checker.Trace
-import qualified OpenAPI.Checker.TracePrefixTree as T
+import OpenAPI.Checker.Paths
+import qualified OpenAPI.Checker.PathsPrefixTree as P
 
 type VarRef = Int
 
@@ -21,30 +21,30 @@ type VarRef = Int
 -- formulas involving variables, conjunctions, and disjunctions. These
 -- operations (and the generated algebra) are monotonous. This ensures that
 -- fixpoints always exist, i.e. that @x = f x@ has at least one solution.
-data FormulaF (f :: k -> Type) (r :: k) (a :: Type) where
-  Result :: a -> FormulaF f r a
-  Errors :: !(T.TracePrefixTree f r) -> FormulaF f r a
+data FormulaF (q :: k -> k -> Type) (f :: k -> Type) (r :: k) (a :: Type) where
+  Result :: a -> FormulaF q f r a
+  Errors :: !(P.PathsPrefixTree q f r) -> FormulaF q f r a
     -- ^ invariant: never empty
-  Apply :: FormulaF f r (b -> c) -> FormulaF f r b -> (c -> a) -> FormulaF f r a
+  Apply :: FormulaF q f r (b -> c) -> FormulaF q f r b -> (c -> a) -> FormulaF q f r a
     -- ^ invariant: at least one of LHS and RHS is not 'Errors', and they are
     -- both not 'Result'
   SelectFirst :: NE.NonEmpty (SomeFormulaF b)
-    -> !(AnItem f r) -> (b -> a) -> FormulaF f r a
+    -> !(AnItem q f r) -> (b -> a) -> FormulaF q f r a
     -- ^ invariant: the list doesn't contain any 'Result's, 'Errors' or
     -- 'SelectFirst'
-  Variable :: !VarRef -> a -> FormulaF f r a
+  Variable :: !VarRef -> a -> FormulaF q f r a
 
-mkApply :: FormulaF f r (b -> c) -> FormulaF f r b -> (c -> a) -> FormulaF f r a
+mkApply :: FormulaF q f r (b -> c) -> FormulaF q f r b -> (c -> a) -> FormulaF q f r a
 mkApply (Result f) x h = h . f <$> x
 mkApply f (Result x) h = h . ($ x) <$> f
 mkApply (Errors e1) (Errors e2) _ = Errors (e1 <> e2)
 mkApply f x h = Apply f x h
 
-mkSelectFirst :: [SomeFormulaF b] -> AnItem f r -> (b -> a) -> FormulaF f r a
+mkSelectFirst :: [SomeFormulaF b] -> AnItem q f r -> (b -> a) -> FormulaF q f r a
 mkSelectFirst fs allE h = case foldMap check fs of
   (First (Just x), _) -> Result (h x)
   (First Nothing, x:xs) -> SelectFirst (x NE.:| xs) allE h
-  (First Nothing, []) -> Errors $ T.singleton allE
+  (First Nothing, []) -> Errors $ P.singleton allE
   where
     check (SomeFormulaF (Result x)) = (First (Just x), mempty)
     check (SomeFormulaF (Errors _)) = (mempty, mempty)
@@ -53,20 +53,20 @@ mkSelectFirst fs allE h = case foldMap check fs of
     check x = (mempty, [x])
 
 data SomeFormulaF (a :: Type) where
-  SomeFormulaF :: FormulaF f r a -> SomeFormulaF a
+  SomeFormulaF :: FormulaF q f r a -> SomeFormulaF a
 
-anError :: AnItem f r -> FormulaF f r a
-anError e = Errors $ T.singleton e
+anError :: AnItem q f r -> FormulaF q f r a
+anError e = Errors $ P.singleton e
 
-errors :: T.TracePrefixTree f r -> FormulaF f r ()
+errors :: P.PathsPrefixTree q f r -> FormulaF q f r ()
 errors t
-  | T.null t = Result ()
+  | P.null t = Result ()
   | otherwise = Errors t
 
-variable :: VarRef -> FormulaF f r ()
+variable :: VarRef -> FormulaF q f r ()
 variable v = Variable v ()
 
-instance Functor (FormulaF f r) where
+instance Functor (FormulaF q f r) where
   fmap f (Result x) = Result (f x)
   fmap _ (Errors e) = Errors e
   fmap f (Apply g x h) = Apply g x (f . h)
@@ -76,14 +76,14 @@ instance Functor (FormulaF f r) where
 instance Functor SomeFormulaF where
   fmap f (SomeFormulaF x) = SomeFormulaF (fmap f x)
 
-instance Applicative (FormulaF f r) where
+instance Applicative (FormulaF q f r) where
   pure = Result
   f <*> x = mkApply f x id
 
-eitherOf :: [FormulaF f' r' a] -> AnItem f r -> FormulaF f r a
+eitherOf :: [FormulaF q' f' r' a] -> AnItem q f r -> FormulaF q f r a
 eitherOf fs allE = mkSelectFirst (map SomeFormulaF fs) allE id
 
-calculate :: FormulaF f r a -> Either (T.TracePrefixTree f r) a
+calculate :: FormulaF q f r a -> Either (P.PathsPrefixTree q f r) a
 calculate (Result x) = Right x
 calculate (Errors e) = Left e
 calculate (Apply f x h) = case calculate f of
@@ -98,15 +98,15 @@ calculate (SelectFirst xs e h) = go (NE.toList xs)
     go (SomeFormulaF r:rs) = case calculate r of
       Left _ -> go rs
       Right x -> Right (h x)
-    go [] = Left $ T.singleton e
+    go [] = Left $ P.singleton e
 calculate (Variable i _) = error $ "Unknown variable " <> show i
 
 -- Approximate for now. Answers yes/no correctly, but the error lists aren't
 -- super accurate. TODO: improve
-maxFixpoint :: VarRef -> FormulaF f r () -> FormulaF f r ()
+maxFixpoint :: VarRef -> FormulaF q f r () -> FormulaF q f r ()
 maxFixpoint i = go
   where
-    go :: FormulaF f r a -> FormulaF f r a
+    go :: FormulaF q f r a -> FormulaF q f r a
     go (Result x) = Result x
     go (Errors e) = Errors e
     go (Apply f x h) = mkApply (go f) (go x) h

src/OpenAPI/Checker/Orphans.hs

@@ -1,21 +1,13 @@
 {-# OPTIONS_GHC -Wno-orphans #-}
 
-module OpenAPI.Checker.Orphans (Step (..)) where
+module OpenAPI.Checker.Orphans () where
 
 import Control.Comonad.Env
 import Data.OpenApi
-import Data.Typeable
 import qualified Data.HashMap.Strict.InsOrd as IOHM
-import OpenAPI.Checker.Trace
 
 deriving newtype instance Ord Reference
 
-instance Typeable a => Steppable (Referenced a) a where
-  data Step (Referenced a) a
-    = InlineStep
-    | ReferencedStep Reference
-    deriving (Eq, Ord, Show)
-
 deriving stock instance Ord a => Ord (Referenced a)
 deriving stock instance Ord Schema
 deriving stock instance Ord AdditionalProperties

src/OpenAPI/Checker/Paths.hs

@@ -1,25 +1,18 @@
 -- | Utilities for traversing heterogeneous trees. A heterogeneous tree is a
 -- collection of datatypes that "contain" eachother in some form of tree
 -- structure.
-module OpenAPI.Checker.Trace
-  ( Steppable (..)
-  , Trace (..)
-  , DiffTrace (..)
-  , catDiffTrace
-  , _DiffTrace
+module OpenAPI.Checker.Paths
+  ( NiceQuiver
+  , Paths (..)
+  , DiffPaths (..)
+  , catDiffPaths
+  , _DiffPaths
   , AnItem (..)
   , step
-  , Traced
-  , Traced'
-  , traced
 
     -- * Reexports
   , (>>>)
   , (<<<)
-  , extract
-  , ask
-  , asks
-  , local
   )
 where
 
@@ -31,53 +24,50 @@ import Data.Type.Equality
 import Type.Reflection
 import Prelude hiding ((.))
 
-class
-  (Typeable a, Typeable b, Ord (Step a b), Show (Step a b)) =>
-  Steppable (a :: k) (b :: k)
-  where
-  -- | How to get from an @a@ node to a @b@ node
-  data Step (a :: k) (b :: k) :: Type
+type NiceQuiver q a b = (Typeable q, Typeable a, Typeable b, Ord (q a b), Show (q a b))
 
--- | How to get from an @a@ node to a @b@ node in possibly multiple steps. Like
--- a list, but indexed. The list is in reverse because in practice we append
+-- | All the possible ways to navigate between nodes in a heterogeneous tree
+-- form a quiver. The hom-sets of the free category constructed from this quiver
+-- are the sets of various multi-step paths between nodes. This is similar to a
+-- list, but indexed. The list is in reverse because in practice we append
 -- items at the end one at a time.
-data Trace (a :: k) (b :: k) where
-  Root :: Trace a a
-  Snoc :: Steppable b c => Trace a b -> !(Step b c) -> Trace a c
-
-deriving stock instance Show (Trace a b)
+data Paths (q :: k -> k -> Type) (a :: k) (b :: k) where
+  Root :: Paths q a a
+  Snoc :: NiceQuiver q b c => Paths q a b -> !(q b c) -> Paths q a c
 
 infixl 5 `Snoc`
 
-step :: Steppable a b => Step a b -> Trace a b
+deriving stock instance Show (Paths q a b)
+
+step :: NiceQuiver q a b => q a b -> Paths q a b
 step s = Root `Snoc` s
 
-instance Category Trace where
+instance Category (Paths q) where
   id = Root
   Root . xs = xs
   (Snoc ys y) . xs = Snoc (ys . xs) y
 
-typeRepRHS :: Typeable b => Trace a b -> TypeRep b
+typeRepRHS :: Typeable b => Paths q a b -> TypeRep b
 typeRepRHS _ = typeRep
 
-typeRepLHS :: Typeable b => Trace a b -> TypeRep a
+typeRepLHS :: Typeable b => Paths q a b -> TypeRep a
 typeRepLHS Root = typeRep
 typeRepLHS (Snoc xs _) = typeRepLHS xs
 
-instance TestEquality (Trace a) where
+instance TestEquality (Paths q a) where
   testEquality Root Root = Just Refl
   testEquality Root (Snoc ys _) = testEquality (typeRepLHS ys) typeRep
   testEquality (Snoc xs _) Root = testEquality typeRep (typeRepLHS xs)
   testEquality (Snoc _ _) (Snoc _ _) = testEquality typeRep typeRep
 
-instance Eq (Trace a b) where
+instance Eq (Paths q a b) where
   Root == Root = True
   Snoc xs x == Snoc ys y
     | Just Refl <- testEquality (typeRepRHS xs) (typeRepRHS ys) =
       xs == ys && x == y
   _ == _ = False
 
-instance Ord (Trace a b) where
+instance Ord (Paths q a b) where
   compare Root Root = EQ
   compare Root (Snoc _ _) = LT
   compare (Snoc _ _) Root = GT
@@ -87,29 +77,29 @@ instance Ord (Trace a b) where
       Nothing -> compare (someTypeRep xs) (someTypeRep ys)
 
 -- | Like a differece list, but indexed.
-newtype DiffTrace (a :: k) (b :: k)
-  = DiffTrace (forall c. Trace c a -> Trace c b)
+newtype DiffPaths (q :: k -> k -> Type) (a :: k) (b :: k)
+  = DiffPaths (forall c. Paths q c a -> Paths q c b)
 
-catDiffTrace :: DiffTrace a b -> DiffTrace b c -> DiffTrace a c
-catDiffTrace (DiffTrace f) (DiffTrace g) = DiffTrace (g . f)
+catDiffPaths :: DiffPaths q a b -> DiffPaths q b c -> DiffPaths q a c
+catDiffPaths (DiffPaths f) (DiffPaths g) = DiffPaths (g . f)
 
-_DiffTrace :: Iso (DiffTrace a b) (DiffTrace c d) (Trace a b) (Trace c d)
-_DiffTrace = dimap (\(DiffTrace f) -> f Root) $
-  fmap $ \xs -> DiffTrace (>>> xs)
+_DiffPaths :: Iso (DiffPaths q a b) (DiffPaths q c d) (Paths q a b) (Paths q c d)
+_DiffPaths = dimap (\(DiffPaths f) -> f Root) $
+  fmap $ \xs -> DiffPaths (>>> xs)
 
 -- | An item related to some path relative to the root @r@.
-data AnItem (f :: k -> Type) (r :: k) where
-  AnItem :: Ord (f a) => Trace r a -> !(f a) -> AnItem f r
+data AnItem (q :: k -> k -> Type) (f :: k -> Type) (r :: k) where
+  AnItem :: Ord (f a) => Paths q r a -> !(f a) -> AnItem q f r
 
 -- the Ord is yuck but we need it and it should be fine in monomorphic cases
 
-instance Eq (AnItem f r) where
+instance Eq (AnItem q f r) where
   AnItem xs fx == AnItem ys fy
     | Just Refl <- testEquality xs ys =
       xs == ys && fx == fy
   _ == _ = False
 
-instance Typeable r => Ord (AnItem f r) where
+instance Typeable r => Ord (AnItem q f r) where
   compare (AnItem xs fx) (AnItem ys fy) =
     case testEquality xs ys of
       Just Refl -> compare xs ys <> compare fx fy
@@ -120,10 +110,3 @@ instance Typeable r => Ord (AnItem f r) where
         Snoc _ _ -> case ys of
           Root -> compare (someTypeRep xs) (someTypeRep ys)
           Snoc _ _ -> compare (someTypeRep xs) (someTypeRep ys)
-
-type Traced r a = Traced' r a a
-
-type Traced' r a b = Env (Trace r a) b
-
-traced :: Trace r a -> b -> Traced' r a b
-traced = env

src/OpenAPI/Checker/PathsPrefixTree.hs

@@ -1,7 +1,7 @@
 {-# LANGUAGE QuantifiedConstraints #-}
 
-module OpenAPI.Checker.TracePrefixTree
-  ( TracePrefixTree
+module OpenAPI.Checker.PathsPrefixTree
+  ( PathsPrefixTree
   , empty
   , singleton
   , fromList
@@ -9,6 +9,7 @@ module OpenAPI.Checker.TracePrefixTree
   , foldWith
   , toList
   , filter
+  , embed
   )
 where
 
@@ -24,22 +25,22 @@ import Data.Type.Equality
 import qualified Data.TypeRepMap as TRM
 import qualified Data.Vector as V
 import qualified GHC.Exts as TRM
-import OpenAPI.Checker.Trace
+import OpenAPI.Checker.Paths
 import Type.Reflection
 import Prelude hiding (filter, null)
 
 -- | A list of @AnItem r f@, but optimized into a prefix tree.
-data TracePrefixTree (f :: k -> Type) (r :: k) = TracePrefixTree
+data PathsPrefixTree (q :: k -> k -> Type) (f :: k -> Type) (r :: k) = PathsPrefixTree
   { rootItems :: !(ASet (f r))
-  , snocItems :: !(TRM.TypeRepMap (AStep f r))
+  , snocItems :: !(TRM.TypeRepMap (AStep q f r))
   }
 
-instance (forall a. ToJSON (f a)) => ToJSON (TracePrefixTree f r) where
+instance (forall a. ToJSON (f a)) => ToJSON (PathsPrefixTree q f r) where
   toJSON =
     Object . getMergableObject
       . foldWith (\t x -> MergableObject . traceObject t $ toJSON x)
 
-deriving instance Eq (TracePrefixTree f a)
+deriving instance Eq (PathsPrefixTree q f a)
 
 -- Kind of orphan. Treat the map as an infinite tuple of @Maybe (f a)@'s, where
 -- the components are ordered by the @SomeTypeRep@ of the @a@.
@@ -69,8 +70,8 @@ compareTRM s1 s2 =
       M.fromList
         [(someTypeRep x, w) | w@(TRM.WrapTypeable x) <- TRM.toList s]
 
-instance Ord (TracePrefixTree f a) where
-  compare (TracePrefixTree r1 s1) (TracePrefixTree r2 s2) =
+instance Ord (PathsPrefixTree q f a) where
+  compare (PathsPrefixTree r1 s1) (PathsPrefixTree r2 s2) =
     compare r1 r2 <> compareTRM s1 s2
 
 data ASet (a :: Type) where
@@ -97,75 +98,80 @@ deriving instance Ord (ASet a)
 instance Monoid (ASet a) where
   mempty = AnEmptySet
 
-data AStep (f :: k -> Type) (r :: k) (a :: k) where
+data AStep (q :: k -> k -> Type) (f :: k -> Type) (r :: k) (a :: k) where
   AStep
-    :: Steppable r a =>
-    !(M.Map (Step r a) (TracePrefixTree f a))
-    -> AStep f r a
+    :: NiceQuiver q r a =>
+    !(M.Map (q r a) (PathsPrefixTree q f a))
+    -> AStep q f r a
 
-deriving instance Eq (AStep f r a)
+deriving instance Eq (AStep q f r a)
 
-deriving instance Ord (AStep f r a)
+deriving instance Ord (AStep q f r a)
 
-singleton :: AnItem f r -> TracePrefixTree f r
-singleton (AnItem ys v) = go ys $ TracePrefixTree (ASet $ S.singleton v) TRM.empty
+singleton :: AnItem q f r -> PathsPrefixTree q f r
+singleton (AnItem ys v) = go ys $ PathsPrefixTree (ASet $ S.singleton v) TRM.empty
   where
-    go :: Trace r a -> TracePrefixTree f a -> TracePrefixTree f r
+    go :: Paths q r a -> PathsPrefixTree q f a -> PathsPrefixTree q f r
     go Root !t = t
     go (Snoc xs x) !t =
       go xs $
-        TracePrefixTree AnEmptySet $
+        PathsPrefixTree AnEmptySet $
           TRM.one $
             AStep $ M.singleton x t
 
-instance Semigroup (TracePrefixTree f r) where
-  TracePrefixTree r1 s1 <> TracePrefixTree r2 s2 =
-    TracePrefixTree (r1 <> r2) (TRM.unionWith joinSteps s1 s2)
+instance Semigroup (PathsPrefixTree q f r) where
+  PathsPrefixTree r1 s1 <> PathsPrefixTree r2 s2 =
+    PathsPrefixTree (r1 <> r2) (TRM.unionWith joinSteps s1 s2)
     where
       joinSteps (AStep m1) (AStep m2) = AStep $ M.unionWith (<>) m1 m2
 
-instance Monoid (TracePrefixTree f r) where
-  mempty = TracePrefixTree mempty TRM.empty
+instance Monoid (PathsPrefixTree q f r) where
+  mempty = PathsPrefixTree mempty TRM.empty
 
-empty :: TracePrefixTree f r
+empty :: PathsPrefixTree q f r
 empty = mempty
 
-fromList :: [AnItem f r] -> TracePrefixTree f r
+fromList :: [AnItem q f r] -> PathsPrefixTree q f r
 fromList = foldMap singleton
 
-null :: TracePrefixTree f r -> Bool
-null (TracePrefixTree AnEmptySet s) = TRM.size s == 0
+null :: PathsPrefixTree q f r -> Bool
+null (PathsPrefixTree AnEmptySet s) = TRM.size s == 0
 null _ = False
 
 foldWith
-  :: forall f m r.
+  :: forall q f m r.
   Monoid m
-  => (forall a. Ord (f a) => Trace r a -> f a -> m)
-  -> TracePrefixTree f r
+  => (forall a. Ord (f a) => Paths q r a -> f a -> m)
+  -> PathsPrefixTree q f r
   -> m
 foldWith k = goTPT Root
   where
-    goTPT :: forall a. Trace r a -> TracePrefixTree f a -> m
+    goTPT :: forall a. Paths q r a -> PathsPrefixTree q f a -> m
     goTPT xs t = goASet xs (rootItems t) <> goTRM xs (snocItems t)
-    goASet :: forall a. Trace r a -> ASet (f a) -> m
+    goASet :: forall a. Paths q r a -> ASet (f a) -> m
     goASet _ AnEmptySet = mempty
     goASet xs (ASet rs) = foldMap (k xs) rs
-    goTRM :: forall a. Trace r a -> TRM.TypeRepMap (AStep f a) -> m
+    goTRM :: forall a. Paths q r a -> TRM.TypeRepMap (AStep q f a) -> m
     goTRM xs s = foldMap (\(TRM.WrapTypeable f) -> goAStep xs f) $ TRM.toList s
-    goAStep :: forall a b. Trace r a -> AStep f a b -> m
+    goAStep :: forall a b. Paths q r a -> AStep q f a b -> m
     goAStep xs (AStep m) =
       M.foldrWithKey (\x t -> (goTPT (Snoc xs x) t <>)) mempty m
 
-toList :: TracePrefixTree f r -> [AnItem f r]
+toList :: PathsPrefixTree q f r -> [AnItem q f r]
 toList t = appEndo (foldWith (\xs f -> Endo (AnItem xs f :)) t) []
 
 -- | Select a subtree by prefix
-filter :: Trace r a -> TracePrefixTree f r -> TracePrefixTree f a
+filter :: Paths q r a -> PathsPrefixTree q f r -> PathsPrefixTree q f a
 filter Root t = t
 filter (Snoc xs x) t =
   foldMap (\(AStep m) -> fold $ M.lookup x m) $
     TRM.lookup $ snocItems $ filter xs t
 
+-- | Embed a subtree in a larger tree with given prefix
+embed :: Paths q r a -> PathsPrefixTree q f a -> PathsPrefixTree q f r
+embed Root t = t
+embed (Snoc xs x) t = embed xs $ PathsPrefixTree AnEmptySet $ TRM.one $ AStep $ M.singleton x t
+
 newtype MergableObject = MergableObject {getMergableObject :: Object}
 
 instance Semigroup MergableObject where
@@ -183,7 +189,7 @@ instance Semigroup MergableObject where
 instance Monoid MergableObject where
   mempty = MergableObject mempty
 
-traceObject :: Trace r a -> Value -> Object
+traceObject :: Paths q r a -> Value -> Object
 traceObject Root (Object o) = o
 traceObject Root v = HM.singleton "root" v
 traceObject (root `Snoc` s) v =

src/OpenAPI/Checker/References.hs

@@ -1,26 +1,32 @@
+{-# OPTIONS_GHC -Wno-orphans #-}
 module OpenAPI.Checker.References
-  ( TracedReferences
+  ( Step (..)
   , dereference
   )
 where
 
 import qualified Data.HashMap.Strict.InsOrd as IOHM
-import Data.Map (Map)
 import Data.Maybe
 import Data.OpenApi
 import Data.Typeable
-import OpenAPI.Checker.Orphans
-import OpenAPI.Checker.Trace
+import OpenAPI.Checker.Orphans ()
+import OpenAPI.Checker.Subtree
 
-type TracedReferences root a = Map Reference (Traced root a)
+instance Typeable a => Steppable (Referenced a) a where
+  data Step (Referenced a) a = InlineStep
+    deriving stock (Eq, Ord, Show)
+
+instance Typeable a => Steppable (Definitions a) a where
+  data Step (Definitions a) a = ReferencedStep Reference
+    deriving stock (Eq, Ord, Show)
 
 dereference
   :: Typeable a
-  => Definitions a
-  -> Traced r (Referenced a)
-  -> Traced r a
+  => Traced (Definitions a)
+  -> Traced (Referenced a)
+  -> Traced a
 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)
+    -> traced (ask defs >>> step (ReferencedStep r)) (fromJust $ IOHM.lookup ref $ extract defs)

src/OpenAPI/Checker/Run.hs

@@ -6,7 +6,7 @@ import Data.HList
 import qualified Data.Yaml as Yaml
 import OpenAPI.Checker.Options
 import OpenAPI.Checker.Subtree
-import OpenAPI.Checker.Trace
+import OpenAPI.Checker.Paths
 import OpenAPI.Checker.Validate.OpenApi ()
 import Prelude hiding (id, (.))
 
@@ -26,5 +26,5 @@ runChecker = do
           Right s -> pure s
   a <- traced Root <$> parseSchema (clientFile opts)
   b <- traced Root <$> parseSchema (serverFile opts)
-  let report = runCompatFormula $ checkCompatibility HNil (ProdCons a b)
+  let report = runCompatFormula $ checkCompatibility HNil Root (ProdCons a b)
   BSC.putStrLn $ Yaml.encode report

src/OpenAPI/Checker/Subtree.hs

@@ -1,45 +1,67 @@
 module OpenAPI.Checker.Subtree
-  ( APIStep (..)
+  ( Steppable (..)
+  , Trace
+  , Traced
+  , Traced'
+  , pattern Traced
+  , traced
   , Subtree (..)
   , CompatM (..)
   , CompatFormula'
   , CompatFormula
   , ProdCons (..)
-  , anyOfSubtreeAt
   , HasUnsupportedFeature (..)
   , swapProdCons
-  , SubtreeCheckIssue (..)
   , runCompatFormula
-  , anyOfM
-  , anyOfAt
-  , issueAtTrace
   , issueAt
-  , tracedIssue
+  , anyOfAt
   , memo
+
+    -- * Reexports
+  , (>>>)
+  , (<<<)
+  , extract
+  , ask
+  , local
+  , step
   )
 where
 
 import Control.Comonad.Env
 import Control.Monad.Identity
 import Control.Monad.State
-import Data.Aeson
 import Data.Functor.Compose
 import Data.HList
 import Data.Kind
 import Data.Monoid
 import Data.OpenApi
-import Data.Text
 import Data.Typeable
+import OpenAPI.Checker.Behavior
 import OpenAPI.Checker.Formula
 import OpenAPI.Checker.Memo
-import OpenAPI.Checker.Trace
-import qualified OpenAPI.Checker.TracePrefixTree as T
+import OpenAPI.Checker.Paths
+import qualified OpenAPI.Checker.PathsPrefixTree as P
 
 class
-  (Subtree a, Subtree b, Steppable a b) =>
-  APIStep (a :: Type) (b :: Type)
+  (Typeable a, Typeable b, Ord (Step a b), Show (Step a b)) =>
+  Steppable (a :: Type) (b :: Type)
   where
-  describeStep :: Step a b -> Text
+  -- | How to get from an @a@ node to a @b@ node
+  data Step a b :: Type
+
+type Trace = Paths Step OpenApi
+
+type Traced' a b = Env (Trace a) b
+
+type Traced a = Traced' a a
+
+pattern Traced :: Trace a -> b -> Traced' a b
+pattern Traced t x = EnvT t (Identity x)
+
+{-# COMPLETE Traced #-}
+
+traced :: Trace a -> a -> Traced a
+traced = env
 
 data ProdCons a = ProdCons
   { producer :: a
@@ -56,7 +78,7 @@ instance Applicative ProdCons where
 
 newtype CompatM a = CompatM
   { unCompatM
-    :: (StateT (MemoState VarRef) Identity) a
+    :: StateT (MemoState VarRef) Identity a
   }
   deriving newtype
     ( Functor
@@ -65,29 +87,21 @@ newtype CompatM a = CompatM
     , MonadState (MemoState VarRef)
     )
 
-type CompatFormula' f r = Compose CompatM (FormulaF f r)
+type CompatFormula' q f r = Compose CompatM (FormulaF q f r)
 
-type CompatFormula = CompatFormula' SubtreeCheckIssue OpenApi
+type CompatFormula = CompatFormula' Behave AnIssue 'APILevel
 
-class (Typeable t, Ord (CheckIssue t), Show (CheckIssue t)) => Subtree (t :: Type) where
+class (Typeable t, Issuable (SubtreeLevel t)) => Subtree (t :: Type) where
   type CheckEnv t :: [Type]
-  data CheckIssue t :: Type
-
-  issueIsUnsupported :: CheckIssue t -> Bool
-  issueIsUnsupported = const False
-
-  -- | If we ever followed a reference, reroute the path through "components"
-  normalizeTrace :: Trace OpenApi t -> Trace OpenApi t
-  normalizeTrace = id
+  type SubtreeLevel t :: BehaviorLevel
 
   checkCompatibility
     :: HasAll (CheckEnv t) xs
     => HList xs
-    -> ProdCons (Traced OpenApi t)
+    -> Behavior (SubtreeLevel t)
+    -> ProdCons (Traced t)
     -> CompatFormula ()
 
-{-# WARNING normalizeTrace "It must be refactored. Does nothing for now" #-}
-
 class HasUnsupportedFeature x where
   hasUnsupportedFeature :: x -> Bool
 
@@ -101,87 +115,41 @@ instance
   hasUnsupportedFeature (Left x) = hasUnsupportedFeature x
   hasUnsupportedFeature (Right x) = hasUnsupportedFeature x
 
-instance Subtree t => HasUnsupportedFeature (CheckIssue t) where
+instance Issuable l => HasUnsupportedFeature (Issue l) where
   hasUnsupportedFeature = issueIsUnsupported
 
+instance HasUnsupportedFeature (AnIssue l) where
+  hasUnsupportedFeature (AnIssue issue) = hasUnsupportedFeature issue
+
 instance
   (forall x. HasUnsupportedFeature (f x))
-  => HasUnsupportedFeature (T.TracePrefixTree f r)
+  => HasUnsupportedFeature (P.PathsPrefixTree q f r)
   where
   hasUnsupportedFeature =
-    getAny . T.foldWith (\_ fa -> Any $ hasUnsupportedFeature fa)
-
-data SubtreeCheckIssue t where
-  SubtreeCheckIssue :: Subtree t => CheckIssue t -> SubtreeCheckIssue t
-
-deriving stock instance Eq (SubtreeCheckIssue t)
-
-deriving stock instance Ord (SubtreeCheckIssue t)
-
-instance Subtree t => ToJSON (CheckIssue t) where
-  toJSON = toJSON . show
-
-instance HasUnsupportedFeature (SubtreeCheckIssue t) where
-  hasUnsupportedFeature (SubtreeCheckIssue i) = hasUnsupportedFeature i
-
-instance ToJSON (SubtreeCheckIssue t) where
-  toJSON (SubtreeCheckIssue i) = toJSON i
+    getAny . P.foldWith (\_ fa -> Any $ hasUnsupportedFeature fa)
 
 runCompatFormula
-  :: CompatFormula' f r a
-  -> Either (T.TracePrefixTree f r) a
+  :: CompatFormula' q f r a
+  -> Either (P.PathsPrefixTree q f r) a
 runCompatFormula (Compose f) =
   calculate . runIdentity . runMemo 0 . unCompatM $ f
 
-issueAtTrace
-  :: Subtree t
-  => Trace r t
-  -> CheckIssue t
-  -> CompatFormula' SubtreeCheckIssue r a
-issueAtTrace xs issue = Compose $ pure $ anError $ AnItem xs $ SubtreeCheckIssue issue
-
-issueAt
-  :: (Subtree t, ComonadEnv (Trace r t) w)
-  => w x
-  -> CheckIssue t
-  -> CompatFormula' SubtreeCheckIssue r a
-issueAt x = issueAtTrace (ask x)
-
-tracedIssue
-  :: (Subtree t, ComonadEnv (Trace r t) w)
-  => w (CheckIssue t)
-  -> CompatFormula' SubtreeCheckIssue r a
-tracedIssue x = issueAtTrace (ask x) (extract x)
-
-anyOfM
-  :: Subtree t
-  => Trace r t
-  -> CheckIssue t
-  -> [CompatFormula' SubtreeCheckIssue r a]
-  -> CompatFormula' SubtreeCheckIssue r a
-anyOfM xs issue fs =
-  Compose $ (`eitherOf` AnItem xs (SubtreeCheckIssue issue)) <$> sequenceA (getCompose <$> fs)
+issueAt :: Issuable l => Paths q r l -> Issue l -> CompatFormula' q AnIssue r a
+issueAt xs issue = Compose $ pure $ anError $ AnItem xs $ AnIssue issue
 
 anyOfAt
-  :: (Subtree t, ComonadEnv (Trace r t) w)
-  => w x
-  -> CheckIssue t
-  -> [CompatFormula' SubtreeCheckIssue r a]
-  -> CompatFormula' SubtreeCheckIssue r a
-anyOfAt x = anyOfM (ask x)
-
-anyOfSubtreeAt
-  :: (Subtree t, ComonadEnv (Trace r t) w)
-  => w x
-  -> CheckIssue t
-  -> [CompatFormula' SubtreeCheckIssue r a]
-  -> CompatFormula' SubtreeCheckIssue r a
-anyOfSubtreeAt _ _ [x] = x
-anyOfSubtreeAt f i fs = anyOfAt f i fs
+  :: Issuable l
+  => Paths q r l
+  -> Issue l
+  -> [CompatFormula' q AnIssue r a]
+  -> CompatFormula' q AnIssue r a
+anyOfAt _ _ [x] = x
+anyOfAt xs issue fs =
+  Compose $ (`eitherOf` AnItem xs (AnIssue issue)) <$> sequenceA (getCompose <$> fs)
 
 fixpointKnot
   :: MonadState (MemoState VarRef) m
-  => KnotTier (FormulaF f r ()) VarRef m
+  => KnotTier (FormulaF q f r ()) VarRef m
 fixpointKnot =
   KnotTier
     { onKnotFound = modifyMemoNonce succ
@@ -190,8 +158,8 @@ fixpointKnot =
     }
 
 memo
-  :: (Typeable r, Subtree t)
-  => (ProdCons (Traced r t) -> CompatFormula ())
-  -> (ProdCons (Traced r t) -> CompatFormula ())
+  :: (Typeable q, Typeable f, NiceQuiver p r t)
+  => (ProdCons (Env (Paths p r t) t) -> CompatFormula' q f r ())
+  -> (ProdCons (Env (Paths p r t) t) -> CompatFormula' q f r ())
 memo f pc = Compose $ do
   memoWithKnot fixpointKnot (getCompose $ f pc) (ask <$> pc)

src/OpenAPI/Checker/Validate/MediaTypeObject.hs

@@ -1,7 +1,8 @@
 {-# OPTIONS_GHC -Wno-orphans #-}
 
 module OpenAPI.Checker.Validate.MediaTypeObject
-  ( CheckIssue(..)
+  ( Issue(..)
+  , Behave(..)
   ) where
 
 import Control.Lens
@@ -12,30 +13,42 @@ import Data.Map.Strict as M
 import Data.OpenApi
 import Data.Text (Text)
 import Network.HTTP.Media (MediaType, mainType, subType)
+import OpenAPI.Checker.Behavior
 import OpenAPI.Checker.Subtree
-import OpenAPI.Checker.Trace
 import OpenAPI.Checker.Validate.Products
 import OpenAPI.Checker.Validate.Schema ()
 
-tracedSchema :: Traced r MediaTypeObject -> Maybe (Traced r (Referenced Schema))
+tracedSchema :: Traced MediaTypeObject -> Maybe (Traced (Referenced Schema))
 tracedSchema mto = _mediaTypeObjectSchema (extract mto) <&> traced (ask mto >>> step MediaTypeSchema)
 
-tracedEncoding :: Traced r MediaTypeObject -> InsOrdHashMap Text (Traced r Encoding)
+tracedEncoding :: Traced MediaTypeObject -> InsOrdHashMap Text (Traced 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
-    = RequestMediaTypeNotFound
-    | ResponseMediaTypeMissing
+instance Issuable 'PayloadLevel where
+  data Issue 'PayloadLevel
+    = PayloadMediaTypeNotFound
     | MediaEncodingIncompat
     | MediaTypeSchemaRequired
+    | MediaEncodingMissing Text
+    | EncodingNotSupported
     deriving (Eq, Ord, Show)
-  checkCompatibility env prodCons@(ProdCons p c) = do
+  issueIsUnsupported = \case
+    EncodingNotSupported -> True
+    _ -> False
+
+instance Behavable 'PayloadLevel 'SchemaLevel where
+  data Behave 'PayloadLevel 'SchemaLevel
+    = PayloadSchema
+    deriving (Eq, Ord, Show)
+
+instance Subtree MediaTypeObject where
+  type SubtreeLevel MediaTypeObject = 'PayloadLevel
+  type CheckEnv MediaTypeObject =
+    '[ MediaType
+     , ProdCons (Traced (Definitions Schema))
+     ]
+  checkCompatibility env beh prodCons@(ProdCons p c) = do
     if | "multipart" == mainType mediaType -> checkEncoding
        | "application" == mainType mediaType &&
          "x-www-form-urlencoded" == subType mediaType -> checkEncoding
@@ -44,8 +57,9 @@ instance Subtree MediaTypeObject where
     -- request
     for_ (tracedSchema c) $ \consRef ->
         case tracedSchema p of
-          Nothing -> issueAt p MediaTypeSchemaRequired
-          Just prodRef -> checkCompatibility env $ ProdCons prodRef consRef
+          Nothing -> issueAt beh MediaTypeSchemaRequired
+          Just prodRef -> checkCompatibility env (beh >>> step PayloadSchema)
+            $ ProdCons prodRef consRef
     pure ()
     where
       mediaType = getH @MediaType env
@@ -56,22 +70,19 @@ instance Subtree MediaTypeObject where
             $ (IOHM.toList $ tracedEncoding mt) <&> \(k, enc) ->
             ( k
             , ProductLike
-              { tracedValue = enc
+              { productValue = enc
               , required = True } )
           encProdCons = getEncoding <$> prodCons
-        in checkProducts (const MediaEncodingMissing)
-           (const $ checkCompatibility HNil) encProdCons
+        in checkProducts beh MediaEncodingMissing
+           (const $ checkCompatibility HNil beh) encProdCons
 
 instance Subtree Encoding where
+  type SubtreeLevel Encoding = 'PayloadLevel
   type CheckEnv Encoding = '[]
-  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 pc =
-    issueAt (producer pc) EncodingNotSupported
+  checkCompatibility _env beh _pc =
+    issueAt beh EncodingNotSupported
 
 instance Steppable MediaTypeObject (Referenced Schema) where
   data Step MediaTypeObject (Referenced Schema) = MediaTypeSchema
@@ -80,3 +91,20 @@ instance Steppable MediaTypeObject (Referenced Schema) where
 instance Steppable MediaTypeObject Encoding where
   data Step MediaTypeObject Encoding = MediaTypeParamEncoding Text
     deriving (Eq, Ord, Show)
+
+instance Behavable 'OperationLevel 'ResponseLevel where
+  data Behave 'OperationLevel 'ResponseLevel
+    = WithStatusCode HttpStatusCode
+    deriving stock (Eq, Ord, Show)
+
+instance Issuable 'OperationLevel where
+  data Issue 'OperationLevel
+    = ResponseCodeNotFound HttpStatusCode
+    | CallbacksNotSupported
+    | ParamNotMatched Text
+    | PathFragmentNotMatched Int
+    | NoRequestBody
+    deriving stock (Eq, Ord, Show)
+  issueIsUnsupported = \case
+    CallbacksNotSupported -> True
+    _ -> False

src/OpenAPI/Checker/Validate/OpenApi.hs

@@ -10,31 +10,78 @@ where
 import Data.HList
 import qualified Data.HashMap.Strict.InsOrd as IOHM
 import Data.OpenApi
+import OpenAPI.Checker.Behavior
+import OpenAPI.Checker.Paths
 import OpenAPI.Checker.Subtree
-import OpenAPI.Checker.Trace
 import OpenAPI.Checker.Validate.ProcessedPathItem
 
-tracedPaths :: Traced r OpenApi -> Traced r ProcessedPathItems
+tracedPaths :: Traced OpenApi -> Traced ProcessedPathItems
 tracedPaths oa = traced (ask oa >>> step OpenApiPathsStep)
   (processPathItems . IOHM.toList . _openApiPaths . extract $ oa)
 
+tracedRequestBodies :: Traced OpenApi -> Traced (Definitions RequestBody)
+tracedRequestBodies oa = traced (ask oa >>> step ComponentsRequestBody)
+  (_componentsRequestBodies . _openApiComponents . extract $ oa)
+
+tracedParameters :: Traced OpenApi -> Traced (Definitions Param)
+tracedParameters oa = traced (ask oa >>> step ComponentsParam)
+  (_componentsParameters . _openApiComponents . extract $ oa)
+
+tracedSecuritySchemes :: Traced OpenApi -> Traced (Definitions SecurityScheme)
+tracedSecuritySchemes oa = traced (ask oa >>> step ComponentsSecurityScheme)
+  (_componentsSecuritySchemes . _openApiComponents . extract $ oa)
+
+tracedResponses :: Traced OpenApi -> Traced (Definitions Response)
+tracedResponses oa = traced (ask oa >>> step ComponentsResponse)
+  (_componentsResponses . _openApiComponents . extract $ oa)
+
+tracedHeaders :: Traced OpenApi -> Traced (Definitions Header)
+tracedHeaders oa = traced (ask oa >>> step ComponentsHeader)
+  (_componentsHeaders . _openApiComponents . extract $ oa)
+
+tracedSchemas :: Traced OpenApi -> Traced (Definitions Schema)
+tracedSchemas oa = traced (ask oa >>> step ComponentsSchema)
+  (_componentsSchemas . _openApiComponents . extract $ oa)
+
 instance Subtree OpenApi where
+  type SubtreeLevel OpenApi = 'APILevel
   type CheckEnv OpenApi = '[]
-  data CheckIssue OpenApi
-    deriving (Eq, Ord, Show)
-  checkCompatibility _ prodCons = do
-    let cs = _openApiComponents . extract <$> prodCons
+  checkCompatibility _ beh prodCons = do
     checkCompatibility @ProcessedPathItems
-      ((_componentsRequestBodies <$> cs)
-         `HCons` (_componentsParameters <$> cs)
-         `HCons` (_componentsSecuritySchemes <$> cs)
-         `HCons` (_componentsResponses <$> cs)
-         `HCons` (_componentsHeaders <$> cs)
-         `HCons` (_componentsSchemas <$> cs)
+      ((tracedRequestBodies <$> prodCons)
+         `HCons` (tracedParameters <$> prodCons)
+         `HCons` (tracedSecuritySchemes <$> prodCons)
+         `HCons` (tracedResponses <$> prodCons)
+         `HCons` (tracedHeaders <$> prodCons)
+         `HCons` (tracedSchemas <$> prodCons)
          `HCons` (_openApiServers . extract <$> prodCons)
          `HCons` HNil)
-      (tracedPaths <$> prodCons)
+      beh (tracedPaths <$> prodCons)
 
 instance Steppable OpenApi ProcessedPathItems where
   data Step OpenApi ProcessedPathItems = OpenApiPathsStep
     deriving (Eq, Ord, Show)
+
+instance Steppable OpenApi (Definitions RequestBody) where
+  data Step OpenApi (Definitions RequestBody) = ComponentsRequestBody
+    deriving (Eq, Ord, Show)
+
+instance Steppable OpenApi (Definitions Param) where
+  data Step OpenApi (Definitions Param) = ComponentsParam
+    deriving (Eq, Ord, Show)
+
+instance Steppable OpenApi (Definitions SecurityScheme) where
+  data Step OpenApi (Definitions SecurityScheme) = ComponentsSecurityScheme
+    deriving (Eq, Ord, Show)
+
+instance Steppable OpenApi (Definitions Response) where
+  data Step OpenApi (Definitions Response) = ComponentsResponse
+    deriving (Eq, Ord, Show)
+
+instance Steppable OpenApi (Definitions Header) where
+  data Step OpenApi (Definitions Header) = ComponentsHeader
+    deriving (Eq, Ord, Show)
+
+instance Steppable OpenApi (Definitions Schema) where
+  data Step OpenApi (Definitions Schema) = ComponentsSchema
+    deriving (Eq, Ord, Show)

src/OpenAPI/Checker/Validate/Operation.hs

@@ -3,7 +3,6 @@
 
 module OpenAPI.Checker.Validate.Operation
   ( MatchedOperation (..)
-  , CheckIssue (..)
   , OperationMethod(..)
   , pathItemMethod
   ) where
@@ -17,21 +16,21 @@ import Data.Map.Strict as M
 import Data.Maybe
 import Data.OpenApi
 import Data.Text (Text)
+import OpenAPI.Checker.Behavior
 import OpenAPI.Checker.References
 import OpenAPI.Checker.Subtree
-import OpenAPI.Checker.Trace
-import OpenAPI.Checker.Validate.Param
+import OpenAPI.Checker.Validate.MediaTypeObject
 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.Server ()
 
 data MatchedOperation = MatchedOperation
   { operation :: !Operation
-  , pathParams :: ![Traced OpenApi Param]
+  , pathParams :: ![Traced Param]
   -- ^ Params from the PathItem
-  , getPathFragments :: !([Traced OpenApi Param] -> [Traced OpenApi PathFragmentParam])
+  , getPathFragments :: !([Traced Param] -> [Traced PathFragmentParam])
   -- ^ Path fragments traced from PathItem. Takes full list of
   -- operation-specific parameters
   }
@@ -41,20 +40,20 @@ type ParamKey = (ParamLocation, Text)
 paramKey :: Param -> ParamKey
 paramKey param = (_paramIn param, _paramName param)
 
-tracedParameters :: Traced r MatchedOperation -> [Traced r (Referenced Param)]
+tracedParameters :: Traced MatchedOperation -> [Traced (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 :: Traced MatchedOperation -> Maybe (Traced (Referenced RequestBody))
 tracedRequestBody oper = _operationRequestBody (operation $ extract oper) <&> traced (ask oper >>> step OperationRequestBodyStep)
 
-tracedResponses :: Traced r MatchedOperation -> Traced r Responses
+tracedResponses :: Traced MatchedOperation -> Traced Responses
 tracedResponses oper = traced (ask oper >>> step OperationResponsesStep)
   $ _operationResponses . operation $ extract oper
 
-tracedSecurity :: Traced r MatchedOperation -> [Traced r SecurityRequirement]
+tracedSecurity :: Traced MatchedOperation -> [Traced SecurityRequirement]
 tracedSecurity oper =
   [ traced (ask oper >>> step (OperationSecurityRequirementStep i)) x
   | (i, x) <- zip [0..] $ _operationSecurity . operation $ extract oper
@@ -63,29 +62,37 @@ tracedSecurity oper =
 -- FIXME: https://github.com/typeable/openapi-diff/issues/28
 tracedServers
   :: [Server] -- ^ Servers from env
-  -> Traced r MatchedOperation
-  -> Traced r [Server]
+  -> Traced MatchedOperation
+  -> Traced [Server]
 tracedServers env oper =
   traced (ask oper >>> step OperationServersStep) $
     case _operationServers . operation $ extract oper of
       [] -> env
       ss -> ss
 
+instance Behavable 'OperationLevel 'PathFragmentLevel where
+  data Behave 'OperationLevel 'PathFragmentLevel
+    = InParam Text
+    | InFragment Int
+    deriving stock (Eq, Ord, Show)
+
+instance Behavable 'OperationLevel 'RequestLevel where
+  data Behave 'OperationLevel 'RequestLevel
+    = InRequest
+    deriving stock (Eq, Ord, Show)
+
 instance Subtree MatchedOperation where
+  type SubtreeLevel MatchedOperation = 'OperationLevel
   type CheckEnv MatchedOperation =
-    '[ ProdCons (Definitions Param)
-     , ProdCons (Definitions RequestBody)
-     , ProdCons (Definitions SecurityScheme)
-     , ProdCons (Definitions Response)
-     , ProdCons (Definitions Header)
-     , ProdCons (Definitions Schema)
+    '[ ProdCons (Traced (Definitions Param))
+     , ProdCons (Traced (Definitions RequestBody))
+     , ProdCons (Traced (Definitions SecurityScheme))
+     , ProdCons (Traced (Definitions Response))
+     , ProdCons (Traced (Definitions Header))
+     , ProdCons (Traced (Definitions Schema))
      , ProdCons [Server]
      ]
-  data CheckIssue MatchedOperation
-    = OperationMissing OperationMethod
-    | CallbacksNotSupported
-    deriving (Eq, Ord, Show)
-  checkCompatibility env prodCons = do
+  checkCompatibility env beh prodCons = do
     checkParameters
     checkRequestBodies
     checkResponses
@@ -98,30 +105,29 @@ instance Subtree MatchedOperation where
         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 :: ProdCons ([Traced Param], [Traced Param])
           tracedParams = getParams <$> paramDefs <*> prodCons
           getParams defs mp =
             let
-              operationParamsMap :: Map ParamKey (Traced OpenApi Param)
+              operationParamsMap :: Map ParamKey (Traced Param)
               operationParamsMap = M.fromList $ do
                 paramRef <- tracedParameters mp
                 let
                   param = dereference defs paramRef
                   key = paramKey . extract $ param
                 pure (key, param)
-              pathParamsMap :: Map ParamKey (Traced OpenApi Param)
+              pathParamsMap :: Map ParamKey (Traced Param)
               pathParamsMap = M.fromList $ do
                 param <- pathParams . extract $ mp
                 pure (paramKey . extract $ param, param)
-              params = M.elems $ M.union operationParamsMap pathParamsMap
-              -- We prefer params from Operation
+              params = M.elems $ M.union operationParamsMap pathParamsMap -- We prefer params from Operation
               splitted = L.partition
                 (\p -> (_paramIn . extract $ p) == ParamPath) params
             in splitted
         checkNonPathParams $ snd <$> tracedParams
         checkPathParams $ fst <$> tracedParams
         pure ()
-      checkNonPathParams :: ProdCons [Traced OpenApi Param] -> CompatFormula ()
+      checkNonPathParams :: ProdCons [Traced Param] -> CompatFormula ()
       checkNonPathParams params = do
         let
           elements = getEls <$> params
@@ -130,30 +136,30 @@ instance Subtree MatchedOperation where
             let
               k = (_paramIn . extract $ p, _paramName . extract $ p)
               v = ProductLike
-                { tracedValue = p
+                { productValue = p
                 , required = fromMaybe False . _paramRequired . extract $ p
                 }
             pure (k, v)
-          check param = do
-            checkCompatibility @Param (singletonH schemaDefs) param
-        checkProducts (ParamNotMatched . snd) (const check) elements
-      checkPathParams :: ProdCons [Traced OpenApi Param] -> CompatFormula ()
+          check (_, name) param = do
+            checkCompatibility @Param (singletonH schemaDefs) (beh >>> step (InParam name)) param
+        checkProducts beh (ParamNotMatched . snd) check elements
+      checkPathParams :: ProdCons [Traced Param] -> CompatFormula ()
       checkPathParams pathParams = do
         let
-          fragments :: ProdCons [Traced OpenApi PathFragmentParam]
+          fragments :: ProdCons [Traced PathFragmentParam]
           fragments = getFragments <$> pathParams <*> prodCons
           getFragments params mop = getPathFragments (extract mop) params
           -- Feed path parameters to the fragments getter
-          check frags = checkCompatibility @PathFragmentParam env frags
+          check idx frags = checkCompatibility @PathFragmentParam env (beh >>> step (InFragment idx)) frags
           elements = fragments <&> \frags -> M.fromList $ zip [0 :: Int ..] $ do
             frag <- frags
             pure $ ProductLike
-              { tracedValue = frag
+              { productValue = frag
               , required = True }
-        checkProducts (const PathFragmentNotMatched) (const check) elements
+        checkProducts beh PathFragmentNotMatched check elements
       checkRequestBodies = do
         let
-          check reqBody = checkCompatibility @RequestBody env reqBody
+          check reqBody = checkCompatibility @RequestBody env (beh >>> step InRequest) reqBody
           elements = getReqBody <$> bodyDefs <*> prodCons
           getReqBody bodyDef mop = M.fromList $ do
             bodyRef <- F.toList . tracedRequestBody $ mop
@@ -161,31 +167,31 @@ instance Subtree MatchedOperation where
               body = dereference bodyDef bodyRef
             -- Single element map
             pure ((), ProductLike
-              { tracedValue = body
+              { productValue = body
               , required = fromMaybe False . _requestBodyRequired . extract $ body
               })
-        checkProducts (const NoRequestBody) (const check) elements
+        checkProducts beh (const NoRequestBody) (const check) elements
       checkResponses = do
         let
           respEnv = HCons (swapProdCons respDefs)
             $ HCons (swapProdCons headerDefs)
             $ HCons (swapProdCons schemaDefs) HNil
           resps = tracedResponses <$> prodCons
-        checkCompatibility respEnv $ swapProdCons resps
+        checkCompatibility respEnv beh $ swapProdCons resps
       -- FIXME: https://github.com/typeable/openapi-diff/issues/27
       checkCallbacks = pure () -- (error "FIXME: not implemented")
       -- FIXME: https://github.com/typeable/openapi-diff/issues/28
       checkOperationSecurity = pure () -- (error "FIXME: not implemented")
       checkServers =
-        checkCompatibility env $
+        checkCompatibility env beh $
           tracedServers <$> getH @(ProdCons [Server]) env <*> prodCons
-      bodyDefs = getH @(ProdCons (Definitions RequestBody)) env
-      respDefs = getH @(ProdCons (Definitions Response)) env
-      headerDefs =  getH @(ProdCons (Definitions Header)) env
-      schemaDefs = getH @(ProdCons (Definitions Schema)) env
-      paramDefs = getH @(ProdCons (Definitions Param)) env
+      bodyDefs = getH @(ProdCons (Traced (Definitions RequestBody))) env
+      respDefs = getH @(ProdCons (Traced (Definitions Response))) env
+      headerDefs =  getH @(ProdCons (Traced (Definitions Header))) env
+      schemaDefs = getH @(ProdCons (Traced (Definitions Schema))) env
+      paramDefs = getH @(ProdCons (Traced (Definitions Param))) env
 
-data OperationMethod = 
+data OperationMethod =
   GetMethod
   | PutMethod
   | PostMethod
@@ -196,7 +202,7 @@ data OperationMethod =
   | TraceMethod
   deriving (Eq, Ord, Show)
 
-pathItemMethod :: OperationMethod -> PathItem -> Maybe Operation 
+pathItemMethod :: OperationMethod -> PathItem -> Maybe Operation
 pathItemMethod = \case
   GetMethod -> _pathItemGet
   PutMethod -> _pathItemPut
@@ -209,22 +215,22 @@ pathItemMethod = \case
 
 instance Steppable MatchedOperation (Referenced Param) where
   data Step MatchedOperation (Referenced Param) = OperationParamsStep Int
-    deriving (Eq, Ord, Show)
+    deriving stock (Eq, Ord, Show)
 
 instance Steppable MatchedOperation (Referenced RequestBody) where
   data Step MatchedOperation (Referenced RequestBody) = OperationRequestBodyStep
-    deriving (Eq, Ord, Show)
+    deriving stock (Eq, Ord, Show)
 
 instance Steppable MatchedOperation Responses where
   data Step MatchedOperation Responses = OperationResponsesStep
-    deriving (Eq, Ord, Show)
+    deriving stock (Eq, Ord, Show)
 
 instance Steppable MatchedOperation SecurityRequirement where
   data Step MatchedOperation SecurityRequirement = OperationSecurityRequirementStep Int
-    deriving (Eq, Ord, Show)
+    deriving stock (Eq, Ord, Show)
 
 instance Steppable MatchedOperation [Server] where
-  data Step MatchedOperation [Server] 
-    = OperationServersStep 
+  data Step MatchedOperation [Server]
+    = OperationServersStep
     | EnvServerStep
     deriving (Eq, Ord, Show)

src/OpenAPI/Checker/Validate/Param.hs

@@ -2,17 +2,18 @@
 {-# OPTIONS_GHC -fno-warn-name-shadowing #-}
 
 module OpenAPI.Checker.Validate.Param
-  ( CheckIssue (..)
+  ( Behave (..)
+  , Issue (..)
   ) where
 
 import Control.Lens
 import Control.Monad
 import Data.Maybe
 import Data.OpenApi
-import Data.Text
-import OpenAPI.Checker.Orphans
+import Data.Text as T
+import OpenAPI.Checker.Behavior
+import OpenAPI.Checker.Orphans ()
 import OpenAPI.Checker.Subtree
-import OpenAPI.Checker.Trace
 import OpenAPI.Checker.Validate.Schema ()
 
 -- | The type is normalized encoding style of the parameter. If two encoding
@@ -42,14 +43,12 @@ paramEncoding p = EncodingStyle
       ParamQuery -> Just $ fromMaybe False $ _paramAllowReserved p
       _ -> Nothing
 
-tracedSchema :: Traced r Param -> Maybe (Traced r (Referenced Schema))
+tracedSchema :: Traced Param -> Maybe (Traced (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
-    = ParamNotMatched Text
-    | ParamNameMismatch
+instance Issuable 'PathFragmentLevel where
+  data Issue 'PathFragmentLevel
+    = ParamNameMismatch
     -- ^ Params have different names
     | ParamEmptinessIncompatible
     -- ^ Consumer requires non-empty param, but producer gives emptyable
@@ -60,28 +59,39 @@ instance Subtree Param where
     -- ^ Params encoded in different styles
     | ParamSchemaMismatch
     -- ^ One of schemas not presented
+    | PathFragmentsDontMatch Text Text
     deriving (Eq, Ord, Show)
-  checkCompatibility env pc@(ProdCons p c) = do
+  issueIsUnsupported _ = False
+
+instance Behavable 'PathFragmentLevel 'SchemaLevel where
+  data Behave 'PathFragmentLevel 'SchemaLevel
+    = InParamSchema
+    deriving (Eq, Ord, Show)
+
+instance Subtree Param where
+  type SubtreeLevel Param = 'PathFragmentLevel
+  type CheckEnv Param = '[ProdCons (Traced (Definitions Schema))]
+  checkCompatibility env beh pc@(ProdCons p c) = do
     when (_paramName (extract p) /= _paramName (extract c))
-      $ issueAt p ParamNameMismatch
+      $ issueAt beh ParamNameMismatch
     when ((fromMaybe False . _paramRequired . extract $ c) &&
           not (fromMaybe False . _paramRequired . extract $ p))
-      $ issueAt p ParamRequired
+      $ issueAt beh ParamRequired
     case (_paramIn . extract $ p, _paramIn . extract $ c) of
       (ParamQuery, ParamQuery) -> do
         -- Emptiness is only for query params
         when ((fromMaybe False . _paramAllowEmptyValue . extract $ p)
               && not (fromMaybe False . _paramAllowEmptyValue . extract $ c))
-          $ issueAt p ParamEmptinessIncompatible
+          $ issueAt beh ParamEmptinessIncompatible
       (a, b) | a == b -> pure ()
-      _ -> issueAt p ParamPlaceIncompatible
+      _ -> issueAt beh ParamPlaceIncompatible
     unless (paramEncoding (extract p) == paramEncoding (extract c))
-      $ issueAt p ParamStyleMismatch
+      $ issueAt beh ParamStyleMismatch
     case tracedSchema <$> pc of
       ProdCons (Just prodSchema) (Just consSchema) -> do
-        checkCompatibility env $ ProdCons prodSchema consSchema
+        checkCompatibility env (beh >>> step InParamSchema) $ ProdCons prodSchema consSchema
       ProdCons Nothing Nothing -> pure ()
-      ProdCons Nothing (Just _consSchema) -> issueAt p ParamSchemaMismatch
+      ProdCons Nothing (Just _consSchema) -> issueAt beh ParamSchemaMismatch
       ProdCons (Just _prodSchema) Nothing -> pure ()
       -- If consumer doesn't care then why we should?
     pure ()

src/OpenAPI/Checker/Validate/PathFragment.hs

@@ -2,7 +2,6 @@ module OpenAPI.Checker.Validate.PathFragment
   ( parsePath
   , PathFragment (..)
   , PathFragmentParam
-  , CheckIssue (..)
   )
 where
 
@@ -11,9 +10,9 @@ import Data.OpenApi
 import Data.Text (Text)
 import qualified Data.Text as T
 import Data.Typeable
+import OpenAPI.Checker.Behavior
 import OpenAPI.Checker.Subtree
-import OpenAPI.Checker.Trace
-import OpenAPI.Checker.Validate.Param ()
+import OpenAPI.Checker.Validate.Param
 
 -- TODO: templates can be only part of the PathFragment. Currently only supports templates as full PathFragment.
 -- https://github.com/typeable/openapi-diff/issues/23
@@ -35,13 +34,13 @@ data PathFragment param
   | DynamicPath param
   deriving stock (Eq, Ord)
 
-type PathFragmentParam = PathFragment (Traced OpenApi Param)
+type PathFragmentParam = PathFragment (Traced Param)
 
 instance (Typeable param) => Steppable (PathFragment param) Param where
   data Step (PathFragment param) Param = StaticPathParam Text
     deriving (Eq, Ord, Show)
 
-tracedPathFragmentParam :: Traced OpenApi PathFragmentParam -> Traced OpenApi Param
+tracedPathFragmentParam :: Traced PathFragmentParam -> Traced Param
 tracedPathFragmentParam pfp = case extract pfp of
   StaticPath s -> traced (ask pfp >>> step (StaticPathParam s))
     $ mempty
@@ -61,16 +60,13 @@ staticStringSchema t =
     }
 
 instance Subtree PathFragmentParam where
+  type SubtreeLevel PathFragmentParam = 'PathFragmentLevel
   type CheckEnv PathFragmentParam =
-    '[ ProdCons (Definitions Schema) ]
-  data CheckIssue PathFragmentParam
-    = PathFragmentNotMatched
-    | PathFragmentsDontMatch Text Text
-    deriving (Eq, Ord, Show)
+    '[ ProdCons (Traced (Definitions Schema)) ]
   -- This case isn't strictly needed. It is here for optimization.
-  checkCompatibility _ (ProdCons (extract -> StaticPath x) c@(extract -> StaticPath y))
+  checkCompatibility _ beh (ProdCons (extract -> StaticPath x) (extract -> StaticPath y))
     = if x == y
       then pure ()
-      else issueAt c (PathFragmentsDontMatch x y)
-  checkCompatibility env prodCons = do
-    checkCompatibility env (tracedPathFragmentParam <$> prodCons)
+      else issueAt beh (PathFragmentsDontMatch x y)
+  checkCompatibility env beh prodCons = do
+    checkCompatibility env beh (tracedPathFragmentParam <$> prodCons)

src/OpenAPI/Checker/Validate/ProcessedPathItem.hs

@@ -9,6 +9,7 @@ module OpenAPI.Checker.Validate.ProcessedPathItem
   )
 where
 
+import Control.Arrow
 import Control.Comonad.Env
 import Control.Monad
 import Data.Foldable as F
@@ -19,9 +20,11 @@ import Data.Map.Strict as M
 import Data.Maybe
 import Data.OpenApi
 import Data.Text as T
+import OpenAPI.Checker.Behavior
+import OpenAPI.Checker.Orphans ()
+import OpenAPI.Checker.Paths
 import OpenAPI.Checker.References
 import OpenAPI.Checker.Subtree
-import OpenAPI.Checker.Trace
 import OpenAPI.Checker.Validate.Operation
 import OpenAPI.Checker.Validate.PathFragment
 import OpenAPI.Checker.Validate.Sums
@@ -38,23 +41,32 @@ processPathItems = ProcessedPathItems . fmap (uncurry ProcessedPathItem)
 newtype ProcessedPathItems =
   ProcessedPathItems {unProcessedPathItems :: [ProcessedPathItem]}
 
-instance Subtree ProcessedPathItems where
-  type
-    CheckEnv ProcessedPathItems =
-      '[ ProdCons (Definitions Param)
-       , ProdCons (Definitions RequestBody)
-       , ProdCons (Definitions SecurityScheme)
-       , ProdCons (Definitions Response)
-       , ProdCons (Definitions Header)
-       , ProdCons (Definitions Schema)
-       , ProdCons [Server]
-       ]
-  data CheckIssue ProcessedPathItems
+instance Issuable 'APILevel where
+  data Issue 'APILevel
     = NoPathsMatched FilePath
     | AllPathsFailed FilePath
     -- When several paths match given but all checks failed
-    deriving (Eq, Ord, Show)
-  checkCompatibility env pc@(ProdCons p c) = do
+    deriving stock (Eq, Ord, Show)
+  issueIsUnsupported _ = False
+
+instance Behavable 'APILevel 'PathLevel where
+  data Behave 'APILevel 'PathLevel
+    = AtPath (ProdCons FilePath) -- TODO: why are there two?
+    deriving stock (Eq, Ord, Show)
+
+instance Subtree ProcessedPathItems where
+  type SubtreeLevel ProcessedPathItems = 'APILevel
+  type
+    CheckEnv ProcessedPathItems =
+      '[ ProdCons (Traced (Definitions Param))
+       , ProdCons (Traced (Definitions RequestBody))
+       , ProdCons (Traced (Definitions SecurityScheme))
+       , ProdCons (Traced (Definitions Response))
+       , ProdCons (Traced (Definitions Header))
+       , ProdCons (Traced (Definitions Schema))
+       , ProdCons [Server]
+       ]
+  checkCompatibility env beh pc@(ProdCons p c) = do
     -- Each path generated by producer must be handled by consumer with exactly
     -- one way
     for_ (unProcessedPathItems . extract $ p) $ \ prodItem -> do
@@ -65,11 +77,11 @@ instance Subtree ProcessedPathItems where
           matched <- F.toList $ matchingPathItems $ ProdCons prodItem consItem
           return matched
       case matchedItems of
-        [] -> issueAt p $ NoPathsMatched prodPath
-        [match] -> checkCompatibility env (retraced <$> pc <*> match)
-        matches -> anyOfAt c (AllPathsFailed prodPath) $ do
+        [] -> issueAt beh $ NoPathsMatched prodPath
+        [match] -> checkCompatibility env (beh >>> step (AtPath $ matchedPath <$> match)) (retraced <$> pc <*> match)
+        matches -> anyOfAt beh (AllPathsFailed prodPath) $ do
           match <- matches
-          pure $ checkCompatibility env (retraced <$> pc <*> match)
+          pure $ checkCompatibility env (beh >>> step (AtPath $ matchedPath <$> match)) (retraced <$> pc <*> match)
     where
       retraced pc mpi = traced (ask pc >>> step (MatchedPathStep $ matchedPath mpi)) mpi
 
@@ -106,14 +118,14 @@ data MatchedPathItem = MatchedPathItem
   -- ^ Pre-parsed path from PathItem
   }
 
-tracedParameters :: Traced r MatchedPathItem -> [Traced r (Referenced Param)]
+tracedParameters :: Traced MatchedPathItem -> [Traced (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 :: Traced MatchedPathItem -> [Env (Trace PathFragmentParam) (PathFragment Text)]
 tracedFragments mpi =
   [ env (ask mpi >>> step (PathFragmentStep i)) x
   | (i, x) <- L.zip [0..] $ pathFragments $ extract mpi
@@ -121,30 +133,40 @@ tracedFragments mpi =
 
 tracedMethod
   :: OperationMethod
-  -> Traced r MatchedPathItem
-  -> Maybe (Env (Trace r MatchedOperation) Operation)
+  -> Traced MatchedPathItem
+  -> Maybe (Traced' MatchedOperation Operation)
 tracedMethod s mpi = env (ask mpi >>> step (OperationMethodStep s)) <$> (pathItemMethod s . pathItem . extract $ mpi)
 
+instance Issuable 'PathLevel where
+  data Issue 'PathLevel
+    = OperationMissing OperationMethod
+    deriving stock (Eq, Ord, Show)
+  issueIsUnsupported _ = False
+
+instance Behavable 'PathLevel 'OperationLevel where
+  data Behave 'PathLevel 'OperationLevel
+    = InOperation OperationMethod
+    deriving (Eq, Ord, Show)
+
 instance Subtree MatchedPathItem where
+  type SubtreeLevel MatchedPathItem = 'PathLevel
   type CheckEnv MatchedPathItem =
-    '[ ProdCons (Definitions Param)
-     , ProdCons (Definitions RequestBody)
-     , ProdCons (Definitions SecurityScheme)
-     , ProdCons (Definitions Response)
-     , ProdCons (Definitions Header)
-     , ProdCons (Definitions Schema)
+    '[ ProdCons (Traced (Definitions Param))
+     , ProdCons (Traced (Definitions RequestBody))
+     , ProdCons (Traced (Definitions SecurityScheme))
+     , ProdCons (Traced (Definitions Response))
+     , ProdCons (Traced (Definitions Header))
+     , ProdCons (Traced (Definitions Schema))
      , ProdCons [Server]
      ]
-  data CheckIssue MatchedPathItem
-    deriving (Eq, Ord, Show)
-  checkCompatibility env prodCons = do
+  checkCompatibility env beh prodCons = do
     let
-      paramDefs = getH @(ProdCons (Definitions Param)) env
+      paramDefs = getH @(ProdCons (Traced (Definitions Param))) env
       pathTracedParams = getPathParams <$> paramDefs <*> prodCons
       getPathParams
-        :: Definitions Param
-        -> Traced r MatchedPathItem
-        -> [Traced r Param]
+        :: Traced (Definitions Param)
+        -> Traced MatchedPathItem
+        -> [Traced Param]
       getPathParams defs mpi = do
         paramRef <- tracedParameters mpi
         pure $ dereference defs paramRef
@@ -153,7 +175,7 @@ instance Subtree MatchedPathItem where
         --  operationParams will be known on Operation check stage, so we give a
         --  function, returning fragments
         let
-          paramsMap :: Map Text (Traced OpenApi Param)
+          paramsMap :: Map Text (Traced Param)
           paramsMap = M.fromList $ do
             tracedParam <- operationParams
             let pname = _paramName . extract $ tracedParam
@@ -166,16 +188,16 @@ instance Subtree MatchedPathItem where
         in tracedFragments mpi <&> fmap convertFragment
       operations = getOperations <$> pathTracedParams <*> pathTracedFragments <*> prodCons
       getOperations pathParams getPathFragments mpi = M.fromList $ do
-        (i, getOp) <- (\m -> (m, tracedMethod m)) <$>
+        (name, getOp) <- (id &&& tracedMethod) <$>
           [GetMethod, PutMethod, PostMethod, DeleteMethod, OptionsMethod, HeadMethod, PatchMethod, DeleteMethod]
         operation <- F.toList $ getOp mpi
         -- Got only Justs here
         let retraced = \op -> MatchedOperation { operation = op, pathParams, getPathFragments }
-        pure (i, retraced <$> operation)
-      check pc = checkCompatibility @MatchedOperation env pc
+        pure (name, retraced <$> operation)
+      check name pc = checkCompatibility @MatchedOperation env (beh >>> step (InOperation name)) pc
     -- Operations are sum-like entities. Use step to operation as key because
     -- why not
-    checkSums OperationMissing (const check) operations
+    checkSums beh OperationMissing check operations
 
 
 instance Steppable ProcessedPathItems MatchedPathItem where

src/OpenAPI/Checker/Validate/Products.hs

@@ -20,30 +20,30 @@ module OpenAPI.Checker.Validate.Products
 import Data.Foldable
 import Data.Map.Strict (Map)
 import qualified Data.Map.Strict as M
+import OpenAPI.Checker.Behavior
+import OpenAPI.Checker.Paths
 import OpenAPI.Checker.Subtree
-import OpenAPI.Checker.Trace
 
 -- | Some entity which is product-like
-data ProductLike root a = ProductLike
-  { tracedValue :: Traced root a
+data ProductLike a = ProductLike
+  { productValue :: a
   , required :: Bool
   }
 
 checkProducts
-  :: forall k r t
-  .  (Subtree t, Ord k)
-  => (k -> CheckIssue t)
+  :: (Ord k, Issuable l)
+  => Paths q r l
+  -> (k -> Issue l)
   -- ^ No required element found
-  -> (k -> ProdCons (Traced r t) -> CompatFormula' SubtreeCheckIssue r ())
-  -> ProdCons (Map k (ProductLike r t))
-  -> CompatFormula' SubtreeCheckIssue r ()
-checkProducts noElt check (ProdCons p c) = for_ (M.toList c) $ \(key, consElt) ->
+  -> (k -> ProdCons t -> CompatFormula' q AnIssue r ())
+  -> ProdCons (Map k (ProductLike t))
+  -> CompatFormula' q AnIssue r ()
+checkProducts xs noElt check (ProdCons p c) = for_ (M.toList c) $ \(key, consElt) ->
   case M.lookup key p of
     Nothing -> case required consElt of
-      True  -> issueAt (tracedValue consElt) $ noElt key
+      True  -> issueAt xs $ noElt key
       False -> pure ()
     Just prodElt -> do
       let
-        elts :: ProdCons (ProductLike r t)
         elts = ProdCons prodElt consElt
-      check key (tracedValue <$> elts)
+      check key (productValue <$> elts)

src/OpenAPI/Checker/Validate/RequestBody.hs

@@ -1,7 +1,7 @@
 {-# OPTIONS_GHC -Wno-orphans #-}
 
 module OpenAPI.Checker.Validate.RequestBody
-  ( CheckIssue (..)
+  ( Issue (..)
   )
 where
 
@@ -11,33 +11,42 @@ import Data.Map.Strict as M
 import Data.Maybe
 import Data.OpenApi
 import Network.HTTP.Media (MediaType)
+import OpenAPI.Checker.Behavior
 import OpenAPI.Checker.Subtree
-import OpenAPI.Checker.Trace
 import OpenAPI.Checker.Validate.MediaTypeObject
 import OpenAPI.Checker.Validate.Sums
 
-tracedContent :: Traced r RequestBody -> IOHM.InsOrdHashMap MediaType (Traced r MediaTypeObject)
+tracedContent :: Traced RequestBody -> IOHM.InsOrdHashMap MediaType (Traced MediaTypeObject)
 tracedContent resp = IOHM.mapWithKey (\k -> traced (ask resp >>> step (RequestMediaTypeObject k)))
   $ _requestBodyContent $ extract resp
 
+instance Issuable 'RequestLevel where
+  data Issue 'RequestLevel
+    = RequestBodyRequired
+    | RequestMediaTypeNotFound MediaType
+    deriving stock (Eq, Ord, Show)
+  issueIsUnsupported _ = False
+
+instance Behavable 'RequestLevel 'PayloadLevel where
+  data Behave 'RequestLevel 'PayloadLevel
+    = InPayload
+    deriving stock (Eq, Ord, Show)
+
 instance Subtree RequestBody where
+  type SubtreeLevel RequestBody = 'RequestLevel
   type CheckEnv RequestBody =
-    '[ ProdCons (Definitions Schema) ]
-  data CheckIssue RequestBody
-    = NoRequestBody
-    | RequestBodyRequired
-    deriving (Eq, Ord, Show)
-  checkCompatibility env prodCons@(ProdCons p c) =
+    '[ ProdCons (Traced (Definitions Schema)) ]
+  checkCompatibility env beh prodCons@(ProdCons p c) =
     if not (fromMaybe False . _requestBodyRequired . extract $ p)
         && (fromMaybe False . _requestBodyRequired . extract $ c)
-    then issueAt p RequestBodyRequired
+    then issueAt beh RequestBodyRequired
     else
       -- Media type object are sums-like entities.
       let
-        check mediaType pc = checkCompatibility @MediaTypeObject (HCons mediaType env) pc
+        check mediaType pc = checkCompatibility @MediaTypeObject (HCons mediaType env) (beh >>> step InPayload) pc
         sumElts = getSum <$> prodCons
         getSum rb = M.fromList . IOHM.toList $ tracedContent rb
-      in checkSums (const RequestMediaTypeNotFound) check sumElts
+      in checkSums beh RequestMediaTypeNotFound check sumElts
 
 instance Steppable RequestBody MediaTypeObject where
   data Step RequestBody MediaTypeObject = RequestMediaTypeObject MediaType

src/OpenAPI/Checker/Validate/Responses.hs

@@ -14,56 +14,70 @@ import Data.Map.Strict as M
 import Data.Maybe
 import Data.OpenApi
 import Network.HTTP.Media (MediaType)
+import OpenAPI.Checker.Behavior
 import OpenAPI.Checker.References
 import OpenAPI.Checker.Subtree
-import OpenAPI.Checker.Trace
 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 :: Traced Responses -> IOHM.InsOrdHashMap HttpStatusCode (Traced (Referenced Response))
 tracedResponses resp = IOHM.mapWithKey (\k -> traced (ask resp >>> step (ResponseCodeStep k)))
   $ _responsesResponses $ extract resp
 
 instance Subtree Responses where
+  type SubtreeLevel Responses = 'OperationLevel
   type CheckEnv Responses =
-    '[ ProdCons (Definitions Response)
-     , ProdCons (Definitions Header)
-     , ProdCons (Definitions Schema)
+    '[ ProdCons (Traced (Definitions Response))
+     , ProdCons (Traced (Definitions Header))
+     , ProdCons (Traced (Definitions Schema))
      ]
-  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
   -- one element
-  checkCompatibility env prodCons = do
+  checkCompatibility env beh prodCons = do
     let
-      defs = getH @(ProdCons (Definitions Response)) env
-      check resps = checkCompatibility @Response env resps
+      defs = getH @(ProdCons (Traced (Definitions Response))) env
+      check code resps = checkCompatibility @Response env (beh >>> step (WithStatusCode code)) resps
       elements = getEls <$> defs <*> prodCons
       getEls respDef resps = M.fromList $ do
         (code, respRef) <- IOHM.toList $ tracedResponses resps
         pure (code, dereference respDef respRef)
-    checkSums (const ResponseCodeNotFound) (const check) elements
+    checkSums beh ResponseCodeNotFound check elements
 
-tracedContent :: Traced r Response -> IOHM.InsOrdHashMap MediaType (Traced r MediaTypeObject)
+tracedContent :: Traced Response -> IOHM.InsOrdHashMap MediaType (Traced MediaTypeObject)
 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 :: Traced Response -> IOHM.InsOrdHashMap HeaderName (Traced (Referenced Header))
 tracedHeaders resp = IOHM.mapWithKey (\k -> traced (ask resp >>> step (ResponseHeader k)))
   $ _responseHeaders $ extract resp
 
+instance Issuable 'ResponseLevel where
+  data Issue 'ResponseLevel
+    = ResponseMediaTypeMissing MediaType
+    | ResponseHeaderMissing HeaderName
+    deriving stock (Eq, Ord, Show)
+  issueIsUnsupported _ = False
+
+instance Behavable 'ResponseLevel 'PayloadLevel where
+  data Behave 'ResponseLevel 'PayloadLevel
+    = ResponsePayload
+    deriving stock (Eq, Ord, Show)
+
+instance Behavable 'ResponseLevel 'HeaderLevel where
+  data Behave 'ResponseLevel 'HeaderLevel
+    = InHeader HeaderName
+    deriving stock (Eq, Ord, Show)
+
 instance Subtree Response where
+  type SubtreeLevel Response = 'ResponseLevel
   type CheckEnv Response =
-    '[ ProdCons (Definitions Header)
-     , ProdCons (Definitions Schema)
+    '[ ProdCons (Traced (Definitions Header))
+     , ProdCons (Traced (Definitions Schema))
      ]
-  data CheckIssue Response
-    = ResponseCodeNotFound
-    deriving (Eq, Ord, Show)
-  checkCompatibility env prodCons = do
+  checkCompatibility env beh prodCons = do
     -- Roles are already swapped. Producer is a server and consumer is a client
     checkMediaTypes
     checkHeaders
@@ -74,60 +88,68 @@ instance Subtree Response where
         let
           check mediaType mtObj =
             let mtEnv = HCons mediaType $ env
-            in checkCompatibility @MediaTypeObject mtEnv mtObj
+            in checkCompatibility @MediaTypeObject mtEnv (beh >>> step ResponsePayload) mtObj
           elements = getEls <$> prodCons
           getEls resp = M.fromList . IOHM.toList $ tracedContent resp
-        checkSums (const ResponseMediaTypeMissing) check elements
+        checkSums beh ResponseMediaTypeMissing check elements
 
       checkHeaders = do
         -- Headers are product-like entities
         let
-          check hdrs = checkCompatibility @Header env hdrs
+          check name hdrs = checkCompatibility @Header env (beh >>> step (InHeader name)) hdrs
           elements = getEls <$> headerDefs <*> prodCons
           getEls headerDef resp = M.fromList $ do
             (hname, headerRef) <- IOHM.toList $ tracedHeaders resp
             let header = dereference headerDef headerRef
             pure (hname, ProductLike
-              { tracedValue = header
+              { productValue = header
               , required = fromMaybe False . _headerRequired . extract $ header
               })
-        checkProducts (const ResponseHeaderMissing) (const check) elements
-      headerDefs = getH @(ProdCons (Definitions Header)) env
+        checkProducts beh ResponseHeaderMissing check elements
+      headerDefs = getH @(ProdCons (Traced (Definitions Header))) env
 
-tracedSchema :: Traced r Header -> Maybe (Traced r (Referenced Schema))
+tracedSchema :: Traced Header -> Maybe (Traced (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
-    = ResponseHeaderMissing
-    | RequiredHeaderMissing
+instance Issuable 'HeaderLevel where
+  data Issue 'HeaderLevel
+    = RequiredHeaderMissing
     | NonEmptyHeaderRequired
     | HeaderSchemaRequired
-    deriving (Eq, Ord, Show)
-  checkCompatibility env (ProdCons p c) = do
+    deriving stock (Eq, Ord, Show)
+  issueIsUnsupported _ = False
+
+instance Behavable 'HeaderLevel 'SchemaLevel where
+  data Behave 'HeaderLevel 'SchemaLevel
+    = InSchema
+    deriving stock (Eq, Ord, Show)
+
+instance Subtree Header where
+  type SubtreeLevel Header = 'HeaderLevel
+  type CheckEnv Header = '[ProdCons (Traced (Definitions Schema))]
+  checkCompatibility env beh (ProdCons p c) = do
     if (fromMaybe False $ _headerRequired $ extract c) && not (fromMaybe False $ _headerRequired $ extract p)
-      then issueAt p RequiredHeaderMissing else pure ()
+      then issueAt beh RequiredHeaderMissing else pure ()
     if not (fromMaybe False $ _headerAllowEmptyValue $ extract c) && (fromMaybe False $ _headerAllowEmptyValue $ extract p)
-      then issueAt p NonEmptyHeaderRequired else pure ()
+      then issueAt beh NonEmptyHeaderRequired else pure ()
     for_ (tracedSchema c) $ \consRef ->
       case tracedSchema p of
-        Nothing -> issueAt p HeaderSchemaRequired
-        Just prodRef -> checkCompatibility env (ProdCons prodRef consRef)
+        Nothing -> issueAt beh HeaderSchemaRequired
+        Just prodRef -> checkCompatibility env (beh >>> step InSchema) (ProdCons prodRef consRef)
     pure ()
 
 instance Steppable Responses (Referenced Response) where
   data Step Responses (Referenced Response) = ResponseCodeStep HttpStatusCode
-    deriving (Eq, Ord, Show)
+    deriving stock (Eq, Ord, Show)
 
 instance Steppable Header (Referenced Schema) where
   data Step Header (Referenced Schema) = HeaderSchema
-    deriving (Eq, Ord, Show)
+    deriving stock (Eq, Ord, Show)
 
 instance Steppable Response (Referenced Header) where
   data Step Response (Referenced Header) = ResponseHeader HeaderName
-    deriving (Eq, Ord, Show)
+    deriving stock (Eq, Ord, Show)
 
 instance Steppable Response MediaTypeObject where
   data Step Response MediaTypeObject = ResponseMediaObject MediaType
-    deriving (Eq, Ord, Show)
+    deriving stock (Eq, Ord, Show)

src/OpenAPI/Checker/Validate/Schema.hs

@@ -39,11 +39,12 @@ import qualified Data.Set as S
 import Data.Text (Text)
 import qualified Data.Text as T hiding (singleton)
 import Data.Typeable
+import OpenAPI.Checker.Behavior
 import OpenAPI.Checker.Orphans ()
 import OpenAPI.Checker.References
+import OpenAPI.Checker.Paths
+import qualified OpenAPI.Checker.PathsPrefixTree as P
 import OpenAPI.Checker.Subtree
-import OpenAPI.Checker.Trace
-import qualified OpenAPI.Checker.TracePrefixTree as T
 
 -- | Type of a JSON value
 data JsonType
@@ -53,7 +54,7 @@ data JsonType
   | String
   | Array
   | Object
-  deriving (Eq, Show)
+  deriving stock (Eq, Ord, Show)
 
 -- | A 'A.Value' whose type we know
 data TypedValue :: JsonType -> Type where
@@ -88,8 +89,8 @@ instance Ord a => Ord (Bound a) where
 
 data Property = Property
   { propRequired :: Bool
-  , propFormula :: ForeachType (JsonFormula OpenApi)
-  , propRefSchema :: Traced OpenApi (Referenced Schema)
+  , propFormula :: ForeachType JsonFormula
+  , propRefSchema :: Traced (Referenced Schema)
   }
   deriving stock (Eq, Ord, Show)
 
@@ -106,17 +107,17 @@ data Condition :: JsonType -> Type where
   Pattern :: !Pattern -> Condition 'String
   StringFormat :: !Format -> Condition 'String
   Items
-    :: !(ForeachType (JsonFormula OpenApi))
-    -> !(Traced OpenApi (Referenced Schema))
+    :: !(ForeachType JsonFormula)
+    -> !(Traced (Referenced Schema))
     -> Condition 'Array
   MaxItems :: !Integer -> Condition 'Array
   MinItems :: !Integer -> Condition 'Array
   UniqueItems :: Condition 'Array
   Properties
     :: !(M.Map Text Property)
-    -> !(ForeachType (JsonFormula OpenApi))
+    -> !(ForeachType JsonFormula)
       -- ^ formula for additional properties
-    -> !(Maybe (Traced OpenApi (Referenced Schema)))
+    -> !(Maybe (Traced (Referenced Schema)))
       -- ^ schema for additional properties, Nothing means bottom
     -> Condition 'Object
   MaxProperties :: !Integer -> Condition 'Object
@@ -158,7 +159,7 @@ deriving stock instance Ord (Condition t)
 deriving stock instance Show (Condition t)
 
 data SomeCondition where
-  SomeCondition :: Typeable t => Traced OpenApi (Condition t) -> SomeCondition
+  SomeCondition :: Typeable t => Condition t -> SomeCondition
 
 instance Eq SomeCondition where
   SomeCondition x == SomeCondition y = case cast x of
@@ -175,26 +176,24 @@ deriving stock instance Show SomeCondition
 -- | A boolean formula (without "not") of 'Condition's. Represented as a
 -- Disjunctive Normal Form: the formula is a disjunction of a set of conjuncts,
 -- each of which is a conjunction of a set of 'Condition's.
-newtype JsonFormula r t
-  = DNF (S.Set (M.Map (Condition t) (Trace r (Condition t))))
+newtype JsonFormula t
+  = DNF (S.Set (S.Set (Condition t)))
   deriving stock (Eq, Ord, Show)
 
 disjAdd
-  :: JsonFormula r t
-  -> M.Map (Condition t) (Trace r (Condition t))
-  -> JsonFormula r t
+  :: JsonFormula t
+  -> S.Set (Condition t)
+  -> JsonFormula t
 disjAdd (DNF yss) xs
-  | any (`isMapSubsetOf` xs) yss = DNF yss
-  | otherwise = DNF $ S.insert xs $ S.filter (not . isMapSubsetOf xs) yss
-  where
-    isMapSubsetOf a b = M.keysSet a `S.isSubsetOf` M.keysSet b
+  | any (`S.isSubsetOf` xs) yss = DNF yss
+  | otherwise = DNF $ S.insert xs $ S.filter (not . S.isSubsetOf xs) yss
 
-instance Lattice (JsonFormula r t) where
+instance Lattice (JsonFormula t) where
   xss \/ DNF yss = S.foldl' disjAdd xss yss
   DNF xss /\ DNF yss = F.foldl' disjAdd bottom $
-    liftA2 M.union (S.toList xss) (S.toList yss)
+    liftA2 S.union (S.toList xss) (S.toList yss)
 
-pattern BottomFormula :: JsonFormula r t
+pattern BottomFormula :: JsonFormula t
 pattern BottomFormula <- DNF (S.null -> True)
   where BottomFormula = DNF S.empty
 
@@ -203,35 +202,35 @@ isSingleton s
   | S.size s == 1 = S.lookupMin 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)
-  where Conjunct xs = M.fromList $ (extract &&& ask) <$> xs
+pattern Conjunct :: [Condition t] -> S.Set (Condition t)
+pattern Conjunct xs <- (S.toList -> xs)
+  where Conjunct = S.fromList
 {-# COMPLETE Conjunct #-}
 
-pattern SingleConjunct :: [Traced r (Condition t)] -> JsonFormula r t
+pattern SingleConjunct :: [Condition t] -> JsonFormula t
 pattern SingleConjunct xs <- DNF (isSingleton -> Just (Conjunct xs))
   where SingleConjunct xs = DNF $ S.singleton $ Conjunct xs
 
-pattern TopFormula :: JsonFormula r t
-pattern TopFormula <- DNF (isSingleton -> Just (M.null -> True))
-  where TopFormula = DNF $ S.singleton M.empty
+pattern TopFormula :: JsonFormula t
+pattern TopFormula <- DNF (isSingleton -> Just (S.null -> True))
+  where TopFormula = DNF $ S.singleton S.empty
 
-instance BoundedJoinSemiLattice (JsonFormula r t) where
+instance BoundedJoinSemiLattice (JsonFormula t) where
   bottom = BottomFormula
 
-instance BoundedMeetSemiLattice (JsonFormula r t) where
+instance BoundedMeetSemiLattice (JsonFormula t) where
   top = TopFormula
 
 foldLattice
   :: BoundedLattice l
-  => (Traced r (Condition t) -> l)
-  -> JsonFormula r t
+  => (Condition t -> l)
+  -> JsonFormula 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 \/ S.foldl' (\x y -> x /\ f y) top w) bottom xss
 
-satisfiesFormula :: TypedValue t -> JsonFormula r t -> Bool
-satisfiesFormula val = foldLattice (satisfiesTyped val . extract)
+satisfiesFormula :: TypedValue t -> JsonFormula t -> Bool
+satisfiesFormula val = foldLattice (satisfiesTyped val)
 
 data ForeachType (f :: JsonType -> Type) = ForeachType
   { forNull :: f 'Null
@@ -242,7 +241,7 @@ data ForeachType (f :: JsonType -> Type) = ForeachType
   , forObject :: f 'Object
   }
 
-satisfies :: A.Value -> ForeachType (JsonFormula r) -> Bool
+satisfies :: A.Value -> ForeachType JsonFormula -> Bool
 satisfies val p = case val of
   A.Null -> satisfiesFormula TNull $ forNull p
   A.Bool b -> satisfiesFormula (TBool b) $ forBoolean p
@@ -257,27 +256,27 @@ deriving stock instance (forall x. Typeable x => Show (f x)) => Show (ForeachTyp
 
 foldType
   :: Monoid m
-  => (forall x. Typeable x => (ForeachType f -> f x) -> m)
+  => (forall x. Typeable x => JsonType -> (ForeachType f -> f x) -> m)
   -> m
 foldType k =
-  k forNull <>
-  k forBoolean <>
-  k forNumber <>
-  k forString <>
-  k forArray <>
-  k forObject
+  k Null forNull <>
+  k Boolean forBoolean <>
+  k Number forNumber <>
+  k String forString <>
+  k Array forArray <>
+  k Object forObject
 
 forType_
   :: Applicative m
-  => (forall x. Typeable x => (ForeachType f -> f x) -> m ())
+  => (forall x. Typeable x => JsonType -> (ForeachType f -> f x) -> m ())
   -> m ()
 forType_ k = do
-  k forNull
-  k forBoolean
-  k forNumber
-  k forString
-  k forArray
-  k forObject
+  k Null forNull
+  k Boolean forBoolean
+  k Number forNumber
+  k String forString
+  k Array forArray
+  k Object forObject
   pure ()
 
 instance (forall x. Lattice (f x)) => Lattice (ForeachType f) where
@@ -320,6 +319,7 @@ instance (forall x. BoundedMeetSemiLattice (f x))
     , forObject = top
     }
 
+{- TODO: remove
 instance Typeable t => Steppable Schema (Condition t) where
   data Step Schema (Condition t)
     = EnumField
@@ -340,6 +340,11 @@ instance Typeable t => Steppable Schema (Condition t) where
     | NullableField
     | IntegerType -- type=integer
     deriving (Eq, Ord, Show)
+-}
+
+instance Behavable 'SchemaLevel 'SchemaLevel where
+  data Behave 'SchemaLevel 'SchemaLevel
+    deriving (Eq, Ord, Show)
 
 instance Steppable Schema (Referenced Schema) where
   data Step Schema (Referenced Schema)
@@ -352,44 +357,42 @@ instance Steppable Schema (Referenced Schema) where
     | PropertiesStep Text
     deriving (Eq, Ord, Show)
 
-type ProcessM = ReaderT (Definitions Schema) (Writer (T.TracePrefixTree SubtreeCheckIssue OpenApi))
+type ProcessM = ReaderT (Traced (Definitions Schema)) (Writer (P.PathsPrefixTree Behave AnIssue 'SchemaLevel))
 
-warn
-  :: (Subtree t, ComonadEnv (Trace OpenApi t) w)
-  => w x -> CheckIssue t -> ProcessM ()
-warn t issue = tell $ T.singleton $ AnItem (ask t) $ SubtreeCheckIssue issue
+warn :: Issue 'SchemaLevel -> ProcessM ()
+warn issue = tell $ P.singleton $ AnItem Root $ AnIssue issue
 
 processRefSchema
-  :: Traced OpenApi (Referenced Schema)
-  -> ProcessM (ForeachType (JsonFormula OpenApi))
+  :: Traced (Referenced Schema)
+  -> ProcessM (ForeachType JsonFormula)
 processRefSchema x = do
   defs <- R.ask
   processSchema $ dereference defs x
 
-tracedAllOf :: Traced r Schema -> Maybe [Traced r (Referenced Schema)]
+tracedAllOf :: Traced Schema -> Maybe [Traced (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 :: Traced Schema -> Maybe [Traced (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 :: Traced Schema -> Maybe [Traced (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 :: Traced Schema -> Maybe (Either (Traced (Referenced Schema)) [Traced (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 :: Traced Schema -> Maybe (Either Bool (Traced (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 :: Traced Schema -> IOHM.InsOrdHashMap Text (Traced (Referenced Schema))
 tracedProperties sch = IOHM.mapWithKey (\k -> traced (ask sch >>> step (PropertiesStep k)))
   $ _schemaProperties $ extract sch
 
@@ -397,35 +400,35 @@ tracedProperties sch = IOHM.mapWithKey (\k -> traced (ask sch >>> step (Properti
 -- for every possible type of a JSON value. The conditions are independent, and
 -- are thus checked independently.
 processSchema
-  :: Traced OpenApi Schema
-  -> ProcessM (ForeachType (JsonFormula OpenApi))
+  :: Traced Schema
+  -> ProcessM (ForeachType JsonFormula)
 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]
+    singletonFormula :: Condition t -> JsonFormula t
+    singletonFormula f = SingleConjunct [f]
 
   allClauses <- case tracedAllOf sch of
     Nothing -> pure []
-    Just [] -> [] <$ warn sch (InvalidSchema "no items in allOf")
+    Just [] -> [] <$ warn (InvalidSchema "no items in allOf")
     Just xs -> mapM processRefSchema xs
 
   anyClause <- case tracedAnyOf sch of
     Nothing -> pure top
-    Just [] -> bottom <$ warn sch (InvalidSchema "no items in anyOf")
+    Just [] -> bottom <$ warn (InvalidSchema "no items in anyOf")
     Just xs -> joins <$> mapM processRefSchema xs
 
   oneClause <- case tracedOneOf sch of
     Nothing -> pure top
-    Just [] -> bottom <$ warn sch (InvalidSchema "no items in oneOf")
+    Just [] -> bottom <$ warn (InvalidSchema "no items in oneOf")
     Just xs -> do
       checkOneOfDisjoint xs >>= \case
         True -> pure ()
-        False -> warn sch (NotSupported "Could not determine that oneOf branches are disjoint")
+        False -> warn (NotSupported "Could not determine that oneOf branches are disjoint")
       joins <$> mapM processRefSchema xs
 
   case _schemaNot of
     Nothing -> pure ()
-    Just _ -> warn sch (NotSupported "not clause is unsupported")
+    Just _ -> warn (NotSupported "not clause is unsupported")
 
   let
     typeClause = case _schemaType of
@@ -437,7 +440,7 @@ processSchema sch@(extract -> Schema{..}) = do
       Just OpenApiNumber -> bottom
         { forBoolean = top }
       Just OpenApiInteger -> bottom
-        { forNumber = singletonFormula IntegerType $ MultipleOf 1 }
+        { forNumber = singletonFormula $ MultipleOf 1 }
       Just OpenApiString -> bottom
         { forString = top }
       Just OpenApiArray -> bottom
@@ -447,27 +450,27 @@ processSchema sch@(extract -> Schema{..}) = do
 
   let
     valueEnum A.Null = bottom
-      { forNull = singletonFormula EnumField $ Exactly TNull }
+      { forNull = singletonFormula $ Exactly TNull }
     valueEnum (A.Bool b) = bottom
-      { forBoolean = singletonFormula EnumField $ Exactly $ TBool b }
+      { forBoolean = singletonFormula $ Exactly $ TBool b }
     valueEnum (A.Number n) = bottom
-      { forNumber = singletonFormula EnumField $ Exactly $ TNumber n }
+      { forNumber = singletonFormula $ Exactly $ TNumber n }
     valueEnum (A.String s) = bottom
-      { forString = singletonFormula EnumField $ Exactly $ TString s }
+      { forString = singletonFormula $ Exactly $ TString s }
     valueEnum (A.Array a) = bottom
-      { forArray = singletonFormula EnumField $ Exactly $ TArray a }
+      { forArray = singletonFormula $ Exactly $ TArray a }
     valueEnum (A.Object o) = bottom
-      { forObject = singletonFormula EnumField $ Exactly $ TObject o }
+      { forObject = singletonFormula $ Exactly $ TObject o }
   enumClause <- case _schemaEnum of
     Nothing -> pure top
-    Just [] -> bottom <$ warn sch (InvalidSchema "no items in enum")
+    Just [] -> bottom <$ warn (InvalidSchema "no items in enum")
     Just xs -> pure $ joins (valueEnum <$> xs)
 
   let
     maximumClause = case _schemaMaximum of
       Nothing -> top
       Just n -> top
-        { forNumber = singletonFormula MaximumFields $ Maximum $
+        { forNumber = singletonFormula $ Maximum $
           case _schemaExclusiveMaximum of
             Just True -> Exclusive n
             _ -> Inclusive n }
@@ -475,7 +478,7 @@ processSchema sch@(extract -> Schema{..}) = do
     minimumClause = case _schemaMinimum of
       Nothing -> top
       Just n -> top
-        { forNumber = singletonFormula MinimumFields $ Minimum $ Down $
+        { forNumber = singletonFormula $ Minimum $ Down $
           case _schemaExclusiveMinimum of
             Just True -> Exclusive $ Down n
             _ -> Inclusive $ Down n }
@@ -483,53 +486,53 @@ processSchema sch@(extract -> Schema{..}) = do
     multipleOfClause = case _schemaMultipleOf of
       Nothing -> top
       Just n -> top
-        { forNumber = singletonFormula MultipleOfField $ MultipleOf n }
+        { forNumber = singletonFormula $ MultipleOf n }
 
   formatClause <- case _schemaFormat of
     Nothing -> pure top
     Just f | f `elem` ["int32", "int64", "float", "double"] -> pure top
-      { forNumber = singletonFormula FormatField $ NumberFormat f }
+      { forNumber = singletonFormula $ NumberFormat f }
     Just f | f `elem` ["byte", "binary", "date", "date-time", "password"] -> pure top
-      { forString = singletonFormula FormatField $ StringFormat f }
-    Just f -> top <$ warn sch (NotSupported $ "Unknown format: " <> f)
+      { forString = singletonFormula $ StringFormat f }
+    Just f -> top <$ warn (NotSupported $ "Unknown format: " <> f)
 
   let
     maxLengthClause = case _schemaMaxLength of
       Nothing -> top
       Just n -> top
-        { forString = singletonFormula MaxLengthField $ MaxLength n }
+        { forString = singletonFormula $ MaxLength n }
 
     minLengthClause = case _schemaMinLength of
       Nothing -> top
       Just n -> top
-        { forString = singletonFormula MinLengthField $ MinLength n }
+        { forString = singletonFormula $ MinLength n }
 
     patternClause = case _schemaPattern of
       Nothing -> top
       Just p -> top
-        { forString = singletonFormula PatternField $ Pattern p }
+        { forString = singletonFormula $ Pattern p }
 
   itemsClause <- case tracedItems sch of
     Nothing -> pure top
     Just (Left rs) -> do
       f <- processRefSchema rs
-      pure top { forArray = singletonFormula ItemsField $ Items f rs }
-    Just (Right _) -> top <$ warn sch (NotSupported "array in items is not supported")
+      pure top { forArray = singletonFormula $ Items f rs }
+    Just (Right _) -> top <$ warn (NotSupported "array in items is not supported")
 
   let
     maxItemsClause = case _schemaMaxItems of
       Nothing -> top
       Just n -> top
-        { forArray = singletonFormula MaxItemsField $ MaxItems n }
+        { forArray = singletonFormula $ MaxItems n }
 
     minItemsClause = case _schemaMinItems of
       Nothing -> top
       Just n -> top
-        { forArray = singletonFormula MinItemsField $ MinItems n }
+        { forArray = singletonFormula $ MinItems n }
 
     uniqueItemsClause = case _schemaUniqueItems of
       Just True -> top
-        { forArray = singletonFormula UniqueItemsField UniqueItems }
+        { forArray = singletonFormula UniqueItems }
       _ -> top
 
   (addProps, addPropSchema) <- case tracedAdditionalProperties sch of
@@ -546,10 +549,10 @@ processSchema sch@(extract -> Schema{..}) = do
         in pure (addProps, fromMaybe fakeSchema addPropSchema)
     pure (k, Property (k `elem` _schemaRequired) f psch)
   let
-    allBottom f = getAll $ foldType $ \ty -> case ty f of
+    allBottom f = getAll $ foldType $ \_ ty -> case ty f of
       BottomFormula -> All True
       _ -> All False
-    allTop f = getAll $ foldType $ \ty -> case ty f of
+    allTop f = getAll $ foldType $ \_ ty -> case ty f of
       TopFormula -> All True
       _ -> All False
     -- remove optional fields whose schemata match that of additional props
@@ -561,21 +564,21 @@ processSchema sch@(extract -> Schema{..}) = do
       = top -- if all fields are optional and have trivial schemata
       | otherwise
       = top
-        { forObject = singletonFormula PropertiesFields $ Properties propMap addProps addPropSchema }
+        { forObject = singletonFormula $ Properties propMap addProps addPropSchema }
 
     maxPropertiesClause = case _schemaMaxProperties of
       Nothing -> top
       Just n -> top
-        { forObject = singletonFormula MaxPropertiesField $ MaxProperties n }
+        { forObject = singletonFormula $ MaxProperties n }
 
     minPropertiesClause = case _schemaMinProperties of
       Nothing -> top
       Just n -> top
-        { forObject = singletonFormula MinPropertiesField $ MinProperties n }
+        { forObject = singletonFormula $ MinProperties n }
 
     nullableClause
       | Just True <- _schemaNullable = bottom
-        { forNull = singletonFormula NullableField $ Exactly TNull }
+        { forNull = singletonFormula $ Exactly TNull }
       | otherwise = bottom
 
   pure $ nullableClause \/ meets (allClauses <>
@@ -585,24 +588,24 @@ processSchema sch@(extract -> Schema{..}) = do
     , uniqueItemsClause, propertiesClause, maxPropertiesClause, minPropertiesClause])
 {- TODO: ReadOnly/WriteOnly -}
 
-checkOneOfDisjoint :: [Traced OpenApi (Referenced Schema)] -> ProcessM Bool
+checkOneOfDisjoint :: [Traced (Referenced Schema)] -> ProcessM Bool
 checkOneOfDisjoint = const $ pure True -- TODO
 
 schemaToFormula
-  :: Definitions Schema
-  -> Traced OpenApi Schema
-  -> (ForeachType (JsonFormula OpenApi), T.TracePrefixTree SubtreeCheckIssue OpenApi)
+  :: Traced (Definitions Schema)
+  -> Traced Schema
+  -> (ForeachType JsonFormula, P.PathsPrefixTree Behave AnIssue 'SchemaLevel)
 schemaToFormula defs rs = runWriter . (`runReaderT` defs) $ processSchema rs
 
 checkFormulas
   :: HasAll (CheckEnv Schema) xs
   => HList xs
-  -> Trace OpenApi Schema
-  -> ProdCons (ForeachType (JsonFormula OpenApi), T.TracePrefixTree SubtreeCheckIssue OpenApi)
+  -> Behavior 'SchemaLevel
+  -> ProdCons (ForeachType JsonFormula, P.PathsPrefixTree Behave AnIssue 'SchemaLevel)
   -> 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
+checkFormulas env beh (ProdCons (fp, ep) (fc, ec)) =
+  case P.toList ep ++ P.toList ec of
+    issues@(_:_) -> F.for_ issues $ \(AnItem t (AnIssue e)) -> issueAt (beh >>> t) e
     [] -> do
       -- We have the following isomorphisms:
       --   (A ⊂ X ∪ Y) = (A ⊂ X) \/ (A ⊂ Y)
@@ -631,120 +634,122 @@ checkFormulas env tr (ProdCons (fp, ep) (fc, ec)) =
       --   (⋃_i ⋂_j A[i,j]) ⊂ ∅ = /\_i (⋂_j A[i,j]) ⊂ ∅
       -- where we again delegate (⋂_j A[j]) ⊂ ∅ to a heuristic, though here the
       -- shortcut of \/_j A[j] ⊂ ∅ hardly helps.
-      forType_ $ \ty ->
+      forType_ $ \tyName ty -> do
+        let beh' = beh >>> step (OfType tyName)
         case (ty fp, ty fc) of
-          (DNF pss, BottomFormula) -> F.for_ pss $ \(Conjunct ps) -> checkContradiction tr ps
+          (DNF pss, BottomFormula) -> F.for_ pss $ \(Conjunct ps) -> checkContradiction beh' ps
           (DNF pss, SingleConjunct cs) -> F.for_ pss $ \(Conjunct ps) -> do
-            F.for_ cs $ checkImplication env ps -- avoid disjuntion if there's only one conjunct
+            F.for_ cs $ checkImplication env beh' ps -- avoid disjuntion if there's only one conjunct
           (DNF pss, DNF css) -> F.for_ pss $ \(Conjunct ps) -> do
-            anyOfM tr (NoMatchingCondition $ SomeCondition <$> ps)
-              [F.for_ cs $ checkImplication env ps | Conjunct cs <- S.toList css]
+            anyOfAt beh' (NoMatchingCondition $ SomeCondition <$> ps)
+              [F.for_ cs $ checkImplication env beh' ps | Conjunct cs <- S.toList css]
 
 checkContradiction
-  :: Trace OpenApi Schema
-  -> [Traced OpenApi (Condition t)]
+  :: Behavior 'TypedSchemaLevel
+  -> [Condition t]
   -> CompatFormula ()
-checkContradiction tr _ = issueAtTrace tr NoContradiction -- TODO
+checkContradiction beh _ = issueAt beh NoContradiction -- TODO
 
 checkImplication
-  :: (HasAll (CheckEnv Schema) xs, Typeable t)
+  :: (HasAll (CheckEnv Schema) xs)
   => HList xs
-  -> [Traced OpenApi (Condition t)]
-  -> Traced OpenApi (Condition t)
+  -> Behavior 'TypedSchemaLevel
+  -> [Condition t]
+  -> Condition t
   -> CompatFormula ()
-checkImplication env prods cons = case findExactly prods of
+checkImplication env beh prods cons = case findExactly prods of
   Just e
-    | all (satisfiesTyped e) (extract <$> prods) ->
-      if satisfiesTyped e $ extract cons then pure ()
-        else issueAt cons (EnumDoesntSatisfy e)
+    | all (satisfiesTyped e) prods ->
+      if satisfiesTyped e cons then pure ()
+        else issueAt beh (EnumDoesntSatisfy $ untypeValue e)
     | otherwise -> pure () -- vacuously true
-  Nothing -> case extract cons of
+  Nothing -> case cons of
     -- the above code didn't catch it, so there's no Exactly condition on the lhs
-    Exactly e -> issueAt cons (NoMatchingEnum e)
+    Exactly e -> issueAt beh (NoMatchingEnum $ untypeValue e)
     Maximum m -> case findRelevant min (\case Maximum m' -> Just m'; _ -> Nothing) prods of
       Just m' -> if m' <= m then pure ()
-        else issueAt cons (MatchingMaximumWeak m m')
-      Nothing -> issueAt cons (NoMatchingMaximum m)
+        else issueAt beh (MatchingMaximumWeak m m')
+      Nothing -> issueAt beh (NoMatchingMaximum m)
     Minimum m -> case findRelevant max (\case Minimum m' -> Just m'; _ -> Nothing) prods of
       Just m' -> if m' >= m then pure ()
-        else issueAt cons (MatchingMinimumWeak (coerce m) (coerce m'))
-      Nothing -> issueAt cons (NoMatchingMinimum (coerce m))
+        else issueAt beh (MatchingMinimumWeak (coerce m) (coerce m'))
+      Nothing -> issueAt beh (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 issueAt cons (MatchingMultipleOfWeak m m')
-      Nothing -> issueAt cons (NoMatchingMultipleOf m)
-    NumberFormat f -> if any (\case NumberFormat f' -> f == f'; _ -> False) $ extract <$> prods
-      then pure () else issueAt cons (NoMatchingFormat f)
+        else issueAt beh (MatchingMultipleOfWeak m m')
+      Nothing -> issueAt beh (NoMatchingMultipleOf m)
+    NumberFormat f -> if any (\case NumberFormat f' -> f == f'; _ -> False) prods
+      then pure () else issueAt beh (NoMatchingFormat f)
     MaxLength m -> case findRelevant min (\case MaxLength m' -> Just m'; _ -> Nothing) prods of
       Just m' -> if m' <= m then pure ()
-        else issueAt cons (MatchingMaxLengthWeak m m')
-      Nothing -> issueAt cons (NoMatchingMaxLength m)
+        else issueAt beh (MatchingMaxLengthWeak m m')
+      Nothing -> issueAt beh (NoMatchingMaxLength m)
     MinLength m -> case findRelevant max (\case MinLength m' -> Just m'; _ -> Nothing) prods of
       Just m' -> if m' >= m then pure ()
-        else issueAt cons (MatchingMinLengthWeak m m')
-      Nothing -> issueAt cons (NoMatchingMinLength m)
-    Pattern p -> if any (\case Pattern p' -> p == p'; _ -> False) $ extract <$> prods
-      then pure () else issueAt cons (NoMatchingPattern p)
-    StringFormat f -> if any (\case StringFormat f' -> f == f'; _ -> False) $ extract <$> prods
-      then pure () else issueAt cons (NoMatchingFormat f)
+        else issueAt beh (MatchingMinLengthWeak m m')
+      Nothing -> issueAt beh (NoMatchingMinLength m)
+    Pattern p -> if any (\case Pattern p' -> p == p'; _ -> False) prods
+      then pure () else issueAt beh (NoMatchingPattern p) -- TODO: regex comparison
+    StringFormat f -> if any (\case StringFormat f' -> f == f'; _ -> False) prods
+      then pure () else issueAt beh (NoMatchingFormat f)
     Items _ cons' -> case findRelevant (<>) (\case Items _ rs -> Just (rs NE.:| []); _ -> Nothing) prods of
-      Just (rs NE.:| []) -> checkCompatibility env $ ProdCons rs cons'
+      Just (rs NE.:| []) -> checkCompatibility env (beh >>> step InItems) $ ProdCons rs cons'
       Just rs -> do
         let sch = Inline mempty { _schemaAllOf = Just . NE.toList $ extract <$> rs }
-        checkCompatibility env $ ProdCons (traced (ask $ NE.head rs) sch) cons' -- TODO: bad trace
-      Nothing -> issueAt cons NoMatchingItems
+        checkCompatibility env (beh >>> step InItems) $ ProdCons (traced (ask $ NE.head rs) sch) cons' -- TODO: bad trace
+      Nothing -> issueAt beh NoMatchingItems
     MaxItems m -> case findRelevant min (\case MaxItems m' -> Just m'; _ -> Nothing) prods of
       Just m' -> if m' <= m then pure ()
-        else issueAt cons (MatchingMaxItemsWeak m m')
-      Nothing -> issueAt cons (NoMatchingMaxItems m)
+        else issueAt beh (MatchingMaxItemsWeak m m')
+      Nothing -> issueAt beh (NoMatchingMaxItems m)
     MinItems m -> case findRelevant max (\case MinItems m' -> Just m'; _ -> Nothing) prods of
       Just m' -> if m' >= m then pure ()
-        else issueAt cons (MatchingMinItemsWeak m m')
-      Nothing -> issueAt cons (NoMatchingMinItems m)
-    UniqueItems -> if any (== UniqueItems) $ extract <$> prods then pure ()
-      else issueAt cons NoMatchingUniqueItems
+        else issueAt beh (MatchingMinItemsWeak m m')
+      Nothing -> issueAt beh (NoMatchingMinItems m)
+    UniqueItems -> if any (== UniqueItems) $ prods then pure ()
+      else issueAt beh 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 go sch sch' = checkCompatibility env (ProdCons sch sch')
+          let go sch sch' = checkCompatibility env (beh >>> step (InProperty k)) (ProdCons sch sch')
           case (M.lookup k props', madd', M.lookup k props, madd) of
             (Nothing, Nothing, _, _) -> pure () -- vacuously
-            (_, _, Nothing, Nothing) -> issueAt cons (UnexpectedProperty k)
+            (_, _, Nothing, Nothing) -> issueAt beh (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) -> issueAt cons (PropertyNowRequired k)
+            (False, True) -> issueAt beh (PropertyNowRequired k)
             _ -> pure ()
           pure ()
         case (madd', madd) of
           (Nothing, _) -> pure () -- vacuously
-          (_, Nothing) -> issueAt cons NoAdditionalProperties
-          (Just add', Just add) -> checkCompatibility env (ProdCons add' add)
+          (_, Nothing) -> issueAt beh NoAdditionalProperties
+          (Just add', Just add) -> checkCompatibility env (beh >>> step InAdditionalProperty) (ProdCons add' add)
         pure ()
-      Nothing -> issueAt cons NoMatchingProperties
+      Nothing -> issueAt beh NoMatchingProperties
     MaxProperties m -> case findRelevant min (\case MaxProperties m' -> Just m'; _ -> Nothing) prods of
       Just m' -> if m' <= m then pure ()
-        else issueAt cons (MatchingMaxPropertiesWeak m m')
-      Nothing -> issueAt cons (NoMatchingMaxProperties m)
+        else issueAt beh (MatchingMaxPropertiesWeak m m')
+      Nothing -> issueAt beh (NoMatchingMaxProperties m)
     MinProperties m -> case findRelevant max (\case MinProperties m' -> Just m'; _ -> Nothing) prods of
       Just m' -> if m' >= m then pure ()
-        else issueAt cons (MatchingMinPropertiesWeak m m')
-      Nothing -> issueAt cons (NoMatchingMinProperties m)
+        else issueAt beh (MatchingMinPropertiesWeak m m')
+      Nothing -> issueAt beh (NoMatchingMinProperties m)
   where
-    findExactly ((extract -> Exactly x):_) = Just x
+    findExactly (Exactly x:_) = Just x
     findExactly (_:xs) = findExactly xs
     findExactly [] = Nothing
     findRelevant combine extr
-      = fmap (foldr1 combine) . NE.nonEmpty . mapMaybe (extr . extract)
+      = fmap (foldr1 combine) . NE.nonEmpty . mapMaybe extr
     lcmScientific (toRational -> a) (toRational -> b)
       = fromRational $ lcm (numerator a) (numerator b) % gcd (denominator a) (denominator b)
 
-instance Typeable t => Subtree (Condition t) where
-  data CheckIssue (Condition t)
-    = EnumDoesntSatisfy (TypedValue t)
-    | NoMatchingEnum (TypedValue t)
+instance Issuable 'TypedSchemaLevel where
+  data Issue 'TypedSchemaLevel
+    = EnumDoesntSatisfy A.Value
+    | NoMatchingEnum A.Value
     | NoMatchingMaximum (Bound Scientific)
     | MatchingMaximumWeak (Bound Scientific) (Bound Scientific)
     | NoMatchingMinimum (Bound Scientific)
@@ -771,29 +776,42 @@ instance Typeable t => Subtree (Condition t) where
     | MatchingMaxPropertiesWeak Integer Integer
     | NoMatchingMinProperties Integer
     | MatchingMinPropertiesWeak Integer Integer
-    deriving stock (Eq, Ord, Show)
-  type CheckEnv (Condition t) = CheckEnv Schema
-  normalizeTrace = undefined
-  checkCompatibility env pc = checkImplication env [producer pc] (consumer pc)
-
-instance Subtree Schema where
-  data CheckIssue Schema
-    = NotSupported Text
-    | InvalidSchema Text
     | NoMatchingCondition [SomeCondition]
     | NoContradiction
     deriving stock (Eq, Ord, Show)
-  type CheckEnv Schema = '[ProdCons (Definitions Schema)]
-  checkCompatibility env schs = do
+  issueIsUnsupported _ = False
+
+instance Issuable 'SchemaLevel where
+  data Issue 'SchemaLevel
+    = NotSupported Text
+    | InvalidSchema Text
+    deriving stock (Eq, Ord, Show)
+  issueIsUnsupported _ = True
+
+instance Behavable 'SchemaLevel 'TypedSchemaLevel where
+  data Behave 'SchemaLevel 'TypedSchemaLevel
+    = OfType JsonType
+    deriving stock (Eq, Ord, Show)
+
+instance Behavable 'TypedSchemaLevel 'SchemaLevel where
+  data Behave 'TypedSchemaLevel 'SchemaLevel
+    = InItems
+    | InProperty Text
+    | InAdditionalProperty
+    deriving stock (Eq, Ord, Show)
+
+instance Subtree Schema where
+  type SubtreeLevel Schema = 'SchemaLevel
+  type CheckEnv Schema = '[ProdCons (Traced (Definitions Schema))]
+  checkCompatibility env beh schs = do
     let defs = getH env
-    checkFormulas env (ask $ producer schs) $ schemaToFormula <$> defs <*> schs
+    checkFormulas env beh $ schemaToFormula <$> defs <*> schs
 
 instance Subtree (Referenced Schema) where
-  data CheckIssue (Referenced Schema)
-    deriving stock (Eq, Ord, Show)
+  type SubtreeLevel (Referenced Schema) = 'SchemaLevel
   type CheckEnv (Referenced Schema) = CheckEnv Schema
-  checkCompatibility env refs = do
+  checkCompatibility env beh refs = do
     let
       defs = getH env
       schs = dereference <$> defs <*> refs
-    checkFormulas env (ask $ producer schs) $ schemaToFormula <$> defs <*> schs
+    checkFormulas env beh $ schemaToFormula <$> defs <*> schs

src/OpenAPI/Checker/Validate/SecurityRequirement.hs

@@ -1,18 +1,23 @@
 {-# OPTIONS_GHC -Wno-orphans #-}
 
 module OpenAPI.Checker.Validate.SecurityRequirement
-  ( CheckIssue (..)
+  ( Issue (..)
   ) where
 
 import Data.OpenApi
+import OpenAPI.Checker.Behavior
 import OpenAPI.Checker.Subtree
 
+instance Issuable 'SecurityRequirementLevel where
+  data Issue 'SecurityRequirementLevel
+    = SecurityRequirementNotMet
+    deriving stock (Eq, Ord, Show)
+  issueIsUnsupported _ = False
+
 instance Subtree SecurityRequirement where
+  type SubtreeLevel SecurityRequirement = 'SecurityRequirementLevel
   type
     CheckEnv SecurityRequirement =
-      '[ ProdCons (Definitions SecurityScheme)
+      '[ ProdCons (Traced (Definitions SecurityScheme))
        ]
-  data CheckIssue SecurityRequirement
-    = SecurityRequirementNotMet
-    deriving (Eq, Ord, Show)
   checkCompatibility = undefined

src/OpenAPI/Checker/Validate/Server.hs

@@ -1,7 +1,7 @@
 {-# OPTIONS_GHC -Wno-orphans #-}
 
 module OpenAPI.Checker.Validate.Server
-  ( CheckIssue (..)
+  ( Issue (..)
   )
 where
 
@@ -20,41 +20,51 @@ import Data.OpenApi
 import Data.Text (Text)
 import qualified Data.Text as T
 import Data.Traversable
+import OpenAPI.Checker.Behavior
+import OpenAPI.Checker.Paths
 import OpenAPI.Checker.Subtree
-import OpenAPI.Checker.Trace
+import OpenAPI.Checker.Validate.MediaTypeObject
 import Prelude as P
 
 tracedParsedServerUrlParts
-  :: Traced' r [Server] Server
-  -> Traced' r ProcessedServer (Either (CheckIssue ProcessedServer) ProcessedServer)
+  :: Server
+  -> Either (Issue 'ServerLevel) ProcessedServer
 tracedParsedServerUrlParts s =
-  let rawURL = _serverUrl $ extract s
-      parsedUrl = parseServerUrl rawURL
-      serverVariables = _serverVariables $ extract s
-   in traced (ask s >>> step (ServerStep rawURL)) $
-        parsedUrl
-          & (traverse . traverse)
-            (\var -> case IOHM.lookup var serverVariables of
-               Nothing -> Left VariableNotDefined
-               Just x -> Right x)
+  let parsedUrl = parseServerUrl $ _serverUrl s
+      lookupVar var = case IOHM.lookup var (_serverVariables s) of
+        Nothing -> Left $ ServerVariableNotDefined var
+        Just x -> Right x
+   in (traverse @[] . traverse @ServerUrlPart) lookupVar parsedUrl
+
+instance Behavable 'OperationLevel 'ServerLevel where
+  data Behave 'OperationLevel 'ServerLevel
+    = InServer Text
+    deriving stock (Eq, Ord, Show)
 
 instance Subtree [Server] where
+  type SubtreeLevel [Server] = 'OperationLevel
   type CheckEnv [Server] = '[]
-  data CheckIssue [Server]
-    deriving (Eq, Ord, Show)
-  checkCompatibility env pcServer = do
+  checkCompatibility env beh pcServer = do
     let (ProdCons (pErrs, pUrls) (cErrs, cUrls)) =
-          pcServer <&> partitionEithers . fmap (bicosequence . tracedParsedServerUrlParts) . sequence
-        bicosequence :: Comonad f => f (Either a b) -> Either (f a) (f b)
-        bicosequence x = case extract x of
-          Left e -> Left $ x $> e
-          Right a -> Right $ x $> a
-        throwAllErrors = traverse_ tracedIssue
-    throwAllErrors pErrs
-    throwAllErrors cErrs
-    for_ pUrls $ \cUrl -> do
-      let potentiallyCompatible = P.filter ((staticCompatible `on` extract) cUrl) cUrls
-      anyOfSubtreeAt cUrl ServerNotMatched $ potentiallyCompatible <&> (checkCompatibility env . ProdCons cUrl)
+          pcServer
+            <&> partitionEithers
+              . fmap
+                (\(Traced t s) ->
+                   let bhv = beh >>> step (InServer $ _serverUrl s)
+                    in case tracedParsedServerUrlParts s of
+                         Left e -> Left $ issueAt bhv e
+                         Right u -> Right (bhv, Traced (t >>> step (ServerStep $ _serverUrl s)) u))
+              . sequence
+    sequenceA_ pErrs
+    sequenceA_ cErrs
+    for_ pUrls $ \(bhv, pUrl) -> do
+      let potentiallyCompatible = P.filter ((staticCompatible `on` extract) pUrl) $ fmap snd cUrls
+      anyOfAt
+        bhv
+        ServerNotMatched
+        [ checkCompatibility env bhv (ProdCons pUrl cUrl)
+        | cUrl <- potentiallyCompatible
+        ]
     pure ()
 
 type ProcessedServer = [ServerUrlPart ServerVariable]
@@ -108,22 +118,26 @@ instance Steppable [Server] ProcessedServer where
   data Step [Server] ProcessedServer = ServerStep Text
     deriving (Eq, Ord, Show)
 
-instance Subtree ProcessedServer where
-  type CheckEnv ProcessedServer = '[]
-  data CheckIssue ProcessedServer
-    = VariableNotDefined
-    | ServerNotMatched
-    | EnumValueNotConsumed Int Text
+instance Issuable 'ServerLevel where
+  data Issue 'ServerLevel
+    = EnumValueNotConsumed Int Text
     | ConsumerNotOpen Int
-    deriving (Eq, Ord, Show)
-  checkCompatibility _ pc@(ProdCons p _) =
+    | ServerVariableNotDefined Text
+    | ServerNotMatched
+    deriving stock (Eq, Ord, Show)
+  issueIsUnsupported _ = False
+
+instance Subtree ProcessedServer where
+  type SubtreeLevel ProcessedServer = 'ServerLevel
+  type CheckEnv ProcessedServer = '[]
+  checkCompatibility _ beh pc =
     -- traversing here is fine because we have already filtered for length
     for_ (zip [0 ..] $ zipProdCons . fmap (fmap unifyPart . extract) $ pc) $ \(i, pcPart) -> case pcPart of
-      (Just x, Just y) -> for_ x $ \v -> unless (v `IOHS.member` y) (issueAt p $ EnumValueNotConsumed i v)
+      (Just x, Just y) -> for_ x $ \v -> unless (v `IOHS.member` y) (issueAt beh $ EnumValueNotConsumed i v)
       -- Consumer can consume anything
       (_, Nothing) -> pure ()
       -- Producer can produce anythings, but consumer has a finite enum ;(
-      (Nothing, Just _) -> issueAt p (ConsumerNotOpen i)
+      (Nothing, Just _) -> issueAt beh (ConsumerNotOpen i)
     where
       zipProdCons :: ProdCons [a] -> [(a, a)]
       zipProdCons (ProdCons x y) = zip x y

src/OpenAPI/Checker/Validate/Sums.hs

@@ -5,22 +5,20 @@ module OpenAPI.Checker.Validate.Sums
 import Data.Foldable
 import Data.Map.Strict (Map)
 import qualified Data.Map.Strict as M
+import OpenAPI.Checker.Behavior
 import OpenAPI.Checker.Subtree
-import OpenAPI.Checker.Trace
-
+import OpenAPI.Checker.Paths
 
 checkSums
-  :: forall k r t
-  .  (Ord k, Subtree t)
-  => (k -> CheckIssue t)
-  -> (k -> ProdCons (Traced r t) -> CompatFormula' SubtreeCheckIssue r ())
-  -> ProdCons (Map k (Traced r t))
-  -> CompatFormula' SubtreeCheckIssue r ()
-checkSums noElt check (ProdCons p c) = for_ (M.toList p) $ \(key, prodElt) ->
+  :: (Ord k, Issuable l)
+  => Paths q r l
+  -> (k -> Issue l)
+  -> (k -> ProdCons t -> CompatFormula' q AnIssue r ())
+  -> ProdCons (Map k t)
+  -> CompatFormula' q AnIssue r ()
+checkSums xs noElt check (ProdCons p c) = for_ (M.toList p) $ \(key, prodElt) ->
   case M.lookup key c of
-    Nothing -> issueAt prodElt $ noElt key
+    Nothing -> issueAt xs $ noElt key
     Just consElt ->
-      let
-        sumElts :: ProdCons (Traced r t)
-        sumElts = ProdCons prodElt consElt
+      let sumElts = ProdCons prodElt consElt
       in check key sumElts

test/Spec/Golden/TraceTree.hs

@@ -7,7 +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.Paths
 import OpenAPI.Checker.Validate.OpenApi ()
 import Spec.Golden.Extra
 import Test.Tasty (TestTree)
@@ -21,4 +21,4 @@ tests =
     "trace-tree.yaml"
     ("a.yaml", "b.yaml")
     Yaml.decodeFileThrow
-    (runCompatFormula . checkCompatibility HNil . fmap (traced Root) . uncurry ProdCons)
+    (runCompatFormula . checkCompatibility HNil Root . fmap (traced Root) . uncurry ProdCons)

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

@@ -1,10 +1,7 @@
 Left:
-  OpenApiPathsStep:
-    MatchedPathStep "/test":
-      OperationMethodStep PostMethod:
-        OperationRequestBodyStep:
-          InlineStep:
-            RequestMediaTypeObject application/json:
-              MediaTypeSchema:
-                ReferencedStep (Reference {getReference = "Test"}):
-                  MaximumFields: MatchingMaximumWeak (Inclusive 2.0) (Inclusive 3.0)
+  AtPath (ProdCons {producer = "/test", consumer = "/test"}):
+    InOperation PostMethod:
+      InRequest:
+        InPayload:
+          PayloadSchema:
+            OfType Number: MatchingMaximumWeak (Inclusive 2.0) (Inclusive 3.0)

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

@@ -1,6 +1,4 @@
 Left:
-  OpenApiPathsStep:
-    MatchedPathStep "/test":
-      OperationMethodStep PostMethod:
-        OperationParamsStep 0:
-          InlineStep: ParamEmptinessIncompatible
+  AtPath (ProdCons {producer = "/test", consumer = "/test"}):
+    InOperation PostMethod:
+      InParam "test1": ParamEmptinessIncompatible

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

@@ -1,8 +1,6 @@
 Left:
-  OpenApiPathsStep:
-    MatchedPathStep "/test":
-      OperationMethodStep PostMethod:
-        OperationParamsStep 0:
-          InlineStep:
-            ParamSchema:
-              InlineStep: NoContradiction
+  AtPath (ProdCons {producer = "/test", consumer = "/test"}):
+    InOperation PostMethod:
+      InParam "test":
+        InParamSchema:
+          OfType String: NoContradiction

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

@@ -1,6 +1,4 @@
 Left:
-  OpenApiPathsStep:
-    MatchedPathStep "/test":
-      OperationMethodStep PostMethod:
-        OperationParamsStep 0:
-          InlineStep: ParamRequired
+  AtPath (ProdCons {producer = "/test", consumer = "/test"}):
+    InOperation PostMethod:
+      InParam "test1": ParamRequired

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

@@ -1,6 +1,3 @@
 Left:
-  OpenApiPathsStep:
-    MatchedPathStep "/test":
-      OperationMethodStep PostMethod:
-        OperationParamsStep 1:
-          InlineStep: ParamNotMatched "test2"
+  AtPath (ProdCons {producer = "/test", consumer = "/test"}):
+    InOperation PostMethod: ParamNotMatched "test2"

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

@@ -1,9 +1,7 @@
 Left:
-  OpenApiPathsStep:
-    MatchedPathStep "/test":
-      OperationMethodStep PostMethod:
-        OperationRequestBodyStep:
-          InlineStep:
-            RequestMediaTypeObject application/json:
-              MediaTypeSchema:
-                InlineStep: NoContradiction
+  AtPath (ProdCons {producer = "/test", consumer = "/test"}):
+    InOperation PostMethod:
+      InRequest:
+        InPayload:
+          PayloadSchema:
+            OfType String: NoContradiction

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

@@ -1,7 +1,4 @@
 Left:
-  OpenApiPathsStep:
-    MatchedPathStep "/test":
-      OperationMethodStep PostMethod:
-        OperationRequestBodyStep:
-          InlineStep:
-            RequestMediaTypeObject application/x-www-form-urlencoded: RequestMediaTypeNotFound
+  AtPath (ProdCons {producer = "/test", consumer = "/test"}):
+    InOperation PostMethod:
+      InRequest: RequestMediaTypeNotFound application/x-www-form-urlencoded

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

@@ -1,6 +1,4 @@
 Left:
-  OpenApiPathsStep:
-    MatchedPathStep "/test":
-      OperationMethodStep PostMethod:
-        OperationRequestBodyStep:
-          InlineStep: RequestBodyRequired
+  AtPath (ProdCons {producer = "/test", consumer = "/test"}):
+    InOperation PostMethod:
+      InRequest: RequestBodyRequired

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

@@ -1,7 +1,3 @@
 Left:
-  OpenApiPathsStep:
-    MatchedPathStep "/test":
-      OperationMethodStep PostMethod:
-        OperationResponsesStep:
-          ResponseCodeStep 500:
-            InlineStep: ResponseCodeNotFound
+  AtPath (ProdCons {producer = "/test", consumer = "/test"}):
+    InOperation PostMethod: ResponseCodeNotFound 500

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

@@ -1,9 +1,4 @@
 Left:
-  OpenApiPathsStep:
-    MatchedPathStep "/test":
-      OperationMethodStep PostMethod:
-        OperationResponsesStep:
-          ResponseCodeStep 200:
-            InlineStep:
-              ResponseHeader "Test2":
-                InlineStep: ResponseHeaderMissing
+  AtPath (ProdCons {producer = "/test", consumer = "/test"}):
+    InOperation PostMethod:
+      WithStatusCode 200: ResponseHeaderMissing "Test2"

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

@@ -1,8 +1,4 @@
 Left:
-  OpenApiPathsStep:
-    MatchedPathStep "/test":
-      OperationMethodStep PostMethod:
-        OperationResponsesStep:
-          ResponseCodeStep 200:
-            InlineStep:
-              ResponseMediaObject application/x-www-form-urlencoded: ResponseMediaTypeMissing
+  AtPath (ProdCons {producer = "/test", consumer = "/test"}):
+    InOperation PostMethod:
+      WithStatusCode 200: ResponseMediaTypeMissing application/x-www-form-urlencoded

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

@@ -1,10 +1,7 @@
 Left:
-  OpenApiPathsStep:
-    MatchedPathStep "/test":
-      OperationMethodStep PostMethod:
-        OperationResponsesStep:
-          ResponseCodeStep 200:
-            InlineStep:
-              ResponseMediaObject application/json:
-                MediaTypeSchema:
-                  InlineStep: NoContradiction
+  AtPath (ProdCons {producer = "/test", consumer = "/test"}):
+    InOperation PostMethod:
+      WithStatusCode 200:
+        ResponsePayload:
+          PayloadSchema:
+            OfType Boolean: NoContradiction

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

@@ -1,17 +1,11 @@
 Left:
-  OpenApiPathsStep:
-    MatchedPathStep "/test":
-      OperationMethodStep PostMethod:
-        OperationResponsesStep:
-          ResponseCodeStep 200:
-            InlineStep:
-              ResponseMediaObject application/json:
-                MediaTypeSchema:
-                  ReferencedStep (Reference {getReference = "Test"}):
-                    PropertiesFields: PropertyNowRequired "property2"
-        OperationRequestBodyStep:
-          InlineStep:
-            RequestMediaTypeObject application/json:
-              MediaTypeSchema:
-                ReferencedStep (Reference {getReference = "Test"}):
-                  PropertiesFields: UnexpectedProperty "property2"
+  AtPath (ProdCons {producer = "/test", consumer = "/test"}):
+    InOperation PostMethod:
+      InRequest:
+        InPayload:
+          PayloadSchema:
+            OfType Object: UnexpectedProperty "property2"
+      WithStatusCode 200:
+        ResponsePayload:
+          PayloadSchema:
+            OfType Object: PropertyNowRequired "property2"

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

@@ -1,10 +1,7 @@
 Left:
-  OpenApiPathsStep:
-    MatchedPathStep "/test":
-      OperationMethodStep PostMethod:
-        OperationRequestBodyStep:
-          InlineStep:
-            RequestMediaTypeObject application/json:
-              MediaTypeSchema:
-                ReferencedStep (Reference {getReference = "Test"}):
-                  PropertiesFields: PropertyNowRequired "property2"
+  AtPath (ProdCons {producer = "/test", consumer = "/test"}):
+    InOperation PostMethod:
+      InRequest:
+        InPayload:
+          PayloadSchema:
+            OfType Object: PropertyNowRequired "property2"

test/golden/common/servers/trace-tree.yaml

@@ -1,9 +1,7 @@
 Left:
-  OpenApiPathsStep:
-    MatchedPathStep "/pets":
-      OperationMethodStep GetMethod:
-        OperationServersStep:
-          ServerStep "http://missing.url": ServerNotMatched
-          ServerStep "http://{x}variable.path/{y}/{openVariable1}/{openVariable2}":
-          - EnumValueNotConsumed 1 "a"
-          - ConsumerNotOpen 7
+  AtPath (ProdCons {producer = "/pets", consumer = "/pets"}):
+    InOperation GetMethod:
+      InServer "http://{x}variable.path/{y}/{openVariable1}/{openVariable2}":
+      - EnumValueNotConsumed 1 "a"
+      - ConsumerNotOpen 7
+      InServer "http://missing.url": ServerNotMatched