Re-emit memoized errors at different behaviors (#66)

* Re-emit memoized errors at different behaviors

* Fix client/server vs server/client memoization

src/OpenAPI/Checker/Behavior.hs

@@ -10,6 +10,7 @@ where
 import Data.Aeson
 import Data.Kind
 import Data.Text as T
+import Data.Typeable
 import OpenAPI.Checker.Paths
 
 -- | Kind
@@ -37,7 +38,7 @@ class
   where
   data Behave a b
 
-class (Ord (Issue l), Show (Issue l)) => Issuable (l :: BehaviorLevel) where
+class (Typeable l, 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

src/OpenAPI/Checker/Formula.hs

@@ -7,6 +7,7 @@ module OpenAPI.Checker.Formula
   , errors
   , calculate
   , maxFixpoint
+  , mapErrors
   ) where
 
 import Data.Kind
@@ -29,7 +30,7 @@ data FormulaF (q :: k -> k -> Type) (f :: k -> Type) (r :: k) (a :: Type) where
     -- ^ invariant: at least one of LHS and RHS is not 'Errors', and they are
     -- both not 'Result'
   SelectFirst :: NE.NonEmpty (SomeFormulaF b)
-    -> !(AnItem q f r) -> (b -> a) -> FormulaF q f r a
+    -> !(P.PathsPrefixTree 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 q f r a
@@ -40,11 +41,11 @@ 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 q f r -> (b -> a) -> FormulaF q f r a
+mkSelectFirst :: [SomeFormulaF b] -> P.PathsPrefixTree 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 $ P.singleton allE
+  (First Nothing, []) -> Errors allE
   where
     check (SomeFormulaF (Result x)) = (First (Just x), mempty)
     check (SomeFormulaF (Errors _)) = (mempty, mempty)
@@ -81,7 +82,7 @@ instance Applicative (FormulaF q f r) where
   f <*> x = mkApply f x id
 
 eitherOf :: [FormulaF q' f' r' a] -> AnItem q f r -> FormulaF q f r a
-eitherOf fs allE = mkSelectFirst (map SomeFormulaF fs) allE id
+eitherOf fs allE = mkSelectFirst (map SomeFormulaF fs) (P.singleton allE) id
 
 calculate :: FormulaF q f r a -> Either (P.PathsPrefixTree q f r) a
 calculate (Result x) = Right x
@@ -98,7 +99,7 @@ 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 $ P.singleton e
+    go [] = Left e
 calculate (Variable i _) = error $ "Unknown variable " <> show i
 
 -- Approximate for now. Answers yes/no correctly, but the error lists aren't
@@ -115,3 +116,10 @@ maxFixpoint i = go
     go v@(Variable _ _) = v
     goSF :: SomeFormulaF a -> SomeFormulaF a
     goSF (SomeFormulaF x) = SomeFormulaF (go x)
+
+mapErrors :: (P.PathsPrefixTree q f r -> P.PathsPrefixTree q' f' r') -> FormulaF q f r a -> FormulaF q' f' r' a
+mapErrors _ (Result x) = Result x
+mapErrors m (Errors e) = Errors $ m e
+mapErrors m (Apply f x h) = mkApply (mapErrors m f) (mapErrors m x) h
+mapErrors m (SelectFirst fs e h) = mkSelectFirst (NE.toList fs) (m e) h
+mapErrors _ (Variable i x) = Variable i x

src/OpenAPI/Checker/Run.hs

@@ -25,8 +25,8 @@ runChecker = do
                 fail "Exiting"
               Right s -> pure s
           Right s -> pure s
-  a <- traced Root <$> parseSchema (clientFile opts)
-  b <- traced Root <$> parseSchema (serverFile opts)
+  a <- traced (step ClientSchema) <$> parseSchema (clientFile opts)
+  b <- traced (step ServerSchema) <$> parseSchema (serverFile opts)
   let report = runCompatFormula $ checkCompatibility HNil Root (ProdCons a b)
       output = case outputMode opts of
         StdoutMode -> BSC.putStrLn

src/OpenAPI/Checker/Subtree.hs

@@ -3,6 +3,7 @@
 module OpenAPI.Checker.Subtree
   ( Steppable (..)
   , Step (..)
+  , TraceRoot
   , Trace
   , Traced
   , Traced'
@@ -69,7 +70,15 @@ class
   -- | How to get from an @a@ node to a @b@ node
   data Step a b :: Type
 
-type Trace = Paths Step OpenApi
+data TraceRoot
+
+instance Steppable TraceRoot OpenApi where
+  data Step TraceRoot OpenApi
+    = ClientSchema
+    | ServerSchema
+    deriving stock (Eq, Ord, Show)
+
+type Trace = Paths Step TraceRoot
 
 type Traced' a b = Env (Trace a) b
 
@@ -117,16 +126,15 @@ type CompatFormula' q f r = Compose CompatM (FormulaF q f r)
 
 type SemanticCompatFormula = CompatFormula' Behave AnIssue 'APILevel
 
-type StructuralCompatFormula = CompatFormula' UnitQuiver Proxy ()
+type StructuralCompatFormula = CompatFormula' VoidQuiver Proxy ()
 
-data UnitQuiver a b where
-  UnitQuiver :: UnitQuiver () ()
+data VoidQuiver a b where
 
-deriving stock instance Eq (UnitQuiver a b)
+deriving stock instance Eq (VoidQuiver a b)
 
-deriving stock instance Ord (UnitQuiver a b)
+deriving stock instance Ord (VoidQuiver a b)
 
-deriving stock instance Show (UnitQuiver a b)
+deriving stock instance Show (VoidQuiver a b)
 
 class (Typeable t, Issuable (SubtreeLevel t)) => Subtree (t :: Type) where
   type CheckEnv t :: [Type]
@@ -155,7 +163,7 @@ checkCompatibility
   -> Behavior (SubtreeLevel t)
   -> ProdCons (Traced t)
   -> SemanticCompatFormula ()
-checkCompatibility e bhv = memo SemanticMemoKey $ \pc ->
+checkCompatibility e bhv = memo bhv SemanticMemoKey $ \pc ->
   case runCompatFormula $ checkSubstructure e pc of
     Left _ -> checkSemanticCompatibility e bhv pc
     Right () -> pure ()
@@ -165,7 +173,7 @@ checkSubstructure
   => HList xs
   -> ProdCons (Traced t)
   -> StructuralCompatFormula ()
-checkSubstructure e = memo StructuralMemoKey $ checkStructuralCompatibility e
+checkSubstructure e = memo Root StructuralMemoKey $ checkStructuralCompatibility e
 
 structuralMaybe
   :: (Subtree a, HasAll (CheckEnv a) xs)
@@ -260,7 +268,7 @@ issueAt :: Issuable l => Paths q r l -> Issue l -> CompatFormula' q AnIssue r a
 issueAt xs issue = Compose $ pure $ anError $ AnItem xs $ AnIssue issue
 
 structuralIssue :: StructuralCompatFormula a
-structuralIssue = Compose $ pure $ anError $ AnItem (step UnitQuiver) Proxy
+structuralIssue = Compose $ pure $ anError $ AnItem Root Proxy
 
 anyOfAt
   :: Issuable l
@@ -283,11 +291,17 @@ fixpointKnot =
     }
 
 memo
-  :: (Typeable (r :: k), Typeable q, Typeable f, Typeable k, Typeable a)
-  => MemoKey
+  :: (Typeable (l :: k), Typeable q, Typeable f, Typeable k, Typeable a)
+  => Paths q r l
+  -> MemoKey
   -> (ProdCons (Traced a) -> CompatFormula' q f r ())
   -> (ProdCons (Traced a) -> CompatFormula' q f r ())
-memo k f pc = Compose $ memoWithKnot fixpointKnot (getCompose $ f pc) (k, ask <$> pc)
+memo bhv k f pc = Compose $ do
+  formula' <- memoWithKnot fixpointKnot (do
+    formula <- getCompose $ f pc
+    pure $ mapErrors (P.filter bhv) formula
+    ) (k, ask <$> pc)
+  pure $ mapErrors (P.embed bhv) formula'
 
 data MemoKey = SemanticMemoKey | StructuralMemoKey
   deriving stock (Eq, Ord)

test/Spec/Golden/TraceTree.hs

@@ -21,4 +21,9 @@ tests =
     "trace-tree.yaml"
     ("a.yaml", "b.yaml")
     Yaml.decodeFileThrow
-    (runCompatFormula . checkCompatibility HNil Root . fmap (traced Root) . uncurry ProdCons)
+    (runCompatFormula . checkCompatibility HNil Root . toPC)
+    where
+      toPC (client, server) = ProdCons
+        { producer = traced (step ClientSchema) client
+        , consumer = traced (step ServerSchema) server
+        }

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

@@ -5,3 +5,7 @@ Left:
         InPayload:
           PayloadSchema:
             OfType Object: UnexpectedProperty "property2"
+      WithStatusCode 200:
+        ResponsePayload:
+          PayloadSchema:
+            OfType Object: PropertyNowRequired "property2"