mirror of
https://github.com/ilyakooo0/compaREST.git
synced 2024-09-11 14:35:25 +03:00
Re-emit memoized errors at different behaviors (#66)
* Re-emit memoized errors at different behaviors * Fix client/server vs server/client memoization
This commit is contained in:
parent
b5ed0cb04a
commit
1e7e283b2c
@ -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
|
||||
|
@ -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
|
||||
|
@ -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
|
||||
|
@ -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)
|
||||
|
@ -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
|
||||
}
|
||||
|
@ -5,3 +5,7 @@ Left:
|
||||
InPayload:
|
||||
PayloadSchema:
|
||||
OfType Object: UnexpectedProperty "property2"
|
||||
WithStatusCode 200:
|
||||
ResponsePayload:
|
||||
PayloadSchema:
|
||||
OfType Object: PropertyNowRequired "property2"
|
||||
|
Loading…
Reference in New Issue
Block a user