@@ -14,7 +14,11 @@ module OpenAPI.Checker.Validate.Schema
1414
1515import Algebra.Lattice
1616import Control.Applicative
17−import Control.Monad.Reader
17+import Control.Arrow
18+import Control.Comonad.Env hiding (env)
19+import Control.Lens hiding (cons)
20+import Control.Monad.Reader hiding (ask)
21+import qualified Control.Monad.Reader as R
1822import Control.Monad.Writer
1923import qualified Data.Aeson as A
2024import Data.Coerce
@@ -154,7 +158,7 @@ deriving stock instance Ord (Condition t)
154158deriving stock instance Show (Condition t)
155159
156160data SomeCondition where
157− SomeCondition :: Typeable t => Condition t -> SomeCondition
161+ SomeCondition :: Typeable t => Traced OpenApi (Condition t) -> SomeCondition
158162
159163instance Eq SomeCondition where
160164 SomeCondition x == SomeCondition y = case cast x of
@@ -200,8 +204,8 @@ isSingleton s
200204 | otherwise = Nothing
201205
202206pattern Conjunct :: [Traced r (Condition t)] -> M.Map (Condition t) (Trace r (Condition t))
203−pattern Conjunct xs <- (map (uncurry $ flip Traced) . M.toList -> xs)
204− where Conjunct xs = M.fromList [(x, t) | Traced t x <- xs]
207+pattern Conjunct xs <- (map (uncurry $ flip traced) . M.toList -> xs)
208+ where Conjunct xs = M.fromList $ (extract &&& ask) <$> xs
205209{-# COMPLETE Conjunct #-}
206210
207211pattern SingleConjunct :: [Traced r (Condition t)] -> JsonFormula r t
@@ -218,19 +222,16 @@ instance BoundedJoinSemiLattice (JsonFormula r t) where
218222instance BoundedMeetSemiLattice (JsonFormula r t) where
219223 top = TopFormula
220224
221−singletonFormula :: Trace r (Condition t) -> Condition t -> JsonFormula r t
222−singletonFormula t x = SingleConjunct [Traced t x]
223−
224225foldLattice
225226 :: BoundedLattice l
226227 => (Traced r (Condition t) -> l)
227228 -> JsonFormula r t
228229 -> l
229230foldLattice f (DNF xss) = S.foldl' (\z w ->
230− z \/ M.foldlWithKey' (\x y t -> x /\ f (Traced t y)) top w) bottom xss
231+ z \/ M.foldlWithKey' (\x y t -> x /\ f (traced t y)) top w) bottom xss
231232
232233satisfiesFormula :: TypedValue t -> JsonFormula r t -> Bool
233−satisfiesFormula val = foldLattice (satisfiesTyped val . getTraced)
234+satisfiesFormula val = foldLattice (satisfiesTyped val . extract)
234235
235236data ForeachType (f :: JsonType -> Type) = ForeachType
236237 { forNull :: f 'Null
@@ -345,22 +346,52 @@ instance Steppable Schema (Referenced Schema) where
345346 = AllOfStep Int
346347 | OneOfStep Int
347348 | AnyOfStep Int
348− | ItemsStep
349+ | ItemsObjectStep
350+ | ItemsArrayStep Int
349351 | AdditionalPropertiesStep
350352 | PropertiesStep Text
351353 deriving (Eq, Ord, Show)
352354
353355type ProcessM = ReaderT (Definitions Schema) (Writer (T.TracePrefixTree SubtreeCheckIssue OpenApi))
354356
355−warn :: Subtree t => Trace OpenApi t -> CheckIssue t -> ProcessM ()
356−warn t x = tell $ T.singleton $ AnItem t $ SubtreeCheckIssue x
357+warn
358+ :: (Subtree t, ComonadEnv (Trace OpenApi t) w)
359+ => w x -> CheckIssue t -> ProcessM ()
360+warn t issue = tell $ T.singleton $ AnItem (ask t) $ SubtreeCheckIssue issue
357361
358362processRefSchema
359363 :: Traced OpenApi (Referenced Schema)
360364 -> ProcessM (ForeachType (JsonFormula OpenApi))
361365processRefSchema x = do
362− defs <- ask
363− processSchema $ dereferenceTraced defs x
366+ defs <- R.ask
367+ processSchema $ dereference defs x
368+
369+tracedAllOf :: Traced r Schema -> Maybe [Traced r (Referenced Schema)]
370+tracedAllOf sch = _schemaAllOf (extract sch) <&> \xs ->
371+ [ traced (ask sch >>> step (AllOfStep i)) x | (i, x) <- zip [0..] xs ]
372+
373+tracedAnyOf :: Traced r Schema -> Maybe [Traced r (Referenced Schema)]
374+tracedAnyOf sch = _schemaAnyOf (extract sch) <&> \xs ->
375+ [ traced (ask sch >>> step (AnyOfStep i)) x | (i, x) <- zip [0..] xs ]
376+
377+tracedOneOf :: Traced r Schema -> Maybe [Traced r (Referenced Schema)]
378+tracedOneOf sch = _schemaOneOf (extract sch) <&> \xs ->
379+ [ traced (ask sch >>> step (OneOfStep i)) x | (i, x) <- zip [0..] xs ]
380+
381+tracedItems :: Traced r Schema -> Maybe (Either (Traced r (Referenced Schema)) [Traced r (Referenced Schema)])
382+tracedItems sch = _schemaItems (extract sch) <&> \case
383+ OpenApiItemsObject x -> Left $ traced (ask sch >>> step ItemsObjectStep) x
384+ OpenApiItemsArray xs -> Right
385+ [ traced (ask sch >>> step (ItemsArrayStep i)) x | (i, x) <- zip [0..] xs ]
386+
387+tracedAdditionalProperties :: Traced r Schema -> Maybe (Either Bool (Traced r (Referenced Schema)))
388+tracedAdditionalProperties sch = _schemaAdditionalProperties (extract sch) <&> \case
389+ AdditionalPropertiesAllowed b -> Left b
390+ AdditionalPropertiesSchema x -> Right $ traced (ask sch >>> step AdditionalPropertiesStep) x
391+
392+tracedProperties :: Traced r Schema -> IOHM.InsOrdHashMap Text (Traced r (Referenced Schema))
393+tracedProperties sch = IOHM.mapWithKey (\k -> traced (ask sch >>> step (PropertiesStep k)))
394+ $ _schemaProperties $ extract sch
364395
365396-- | Turn a schema into a tuple of 'JsonFormula's that describes the condition
366397-- for every possible type of a JSON value. The conditions are independent, and
@@ -368,36 +399,33 @@ processRefSchema x = do
368399processSchema
369400 :: Traced OpenApi Schema
370401 -> ProcessM (ForeachType (JsonFormula OpenApi))
371−processSchema (Traced t Schema{..}) = do
402+processSchema sch@(extract -> Schema{..}) = do
403+ let
404+ singletonFormula :: Typeable t => Step Schema (Condition t) -> Condition t -> JsonFormula OpenApi t
405+ singletonFormula t f = SingleConjunct [traced (ask sch >>> step t) f]
372406
373− allClauses <- case _schemaAllOf of
407+ allClauses <- case tracedAllOf sch of
374408 Nothing -> pure []
375− Just [] -> [] <$ warn t (InvalidSchema "no items in allOf")
376− Just xs -> sequence
377− [ processRefSchema (Traced (t `Snoc` AllOfStep i) rs)
378− | (i, rs) <- zip [0..] xs ]
409+ Just [] -> [] <$ warn sch (InvalidSchema "no items in allOf")
410+ Just xs -> mapM processRefSchema xs
379411
380− anyClause <- case _schemaAnyOf of
412+ anyClause <- case tracedAnyOf sch of
381413 Nothing -> pure top
382− Just [] -> bottom <$ warn t (InvalidSchema "no items in anyOf")
383− Just xs -> joins <$> sequence
384− [ processRefSchema (Traced (t `Snoc` AnyOfStep i) rs)
385− | (i, rs) <- zip [0..] xs ]
414+ Just [] -> bottom <$ warn sch (InvalidSchema "no items in anyOf")
415+ Just xs -> joins <$> mapM processRefSchema xs
386416
387− oneClause <- case _schemaOneOf of
417+ oneClause <- case tracedOneOf sch of
388418 Nothing -> pure top
389− Just [] -> bottom <$ warn t (InvalidSchema "no items in oneOf")
419+ Just [] -> bottom <$ warn sch (InvalidSchema "no items in oneOf")
390420 Just xs -> do
391421 checkOneOfDisjoint xs >>= \case
392422 True -> pure ()
393− False -> warn t (NotSupported "Could not determine that oneOf branches are disjoint")
394− joins <$> sequence
395− [ processRefSchema (Traced (t `Snoc` OneOfStep i) rs)
396− | (i, rs) <- zip [0..] xs ]
423+ False -> warn sch (NotSupported "Could not determine that oneOf branches are disjoint")
424+ joins <$> mapM processRefSchema xs
397425
398426 case _schemaNot of
399427 Nothing -> pure ()
400− Just _ -> warn t (NotSupported "not clause is unsupported")
428+ Just _ -> warn sch (NotSupported "not clause is unsupported")
401429
402430 let
403431 typeClause = case _schemaType of
@@ -409,7 +437,7 @@ processSchema (Traced t Schema{..}) = do
409437 Just OpenApiNumber -> bottom
410438 { forBoolean = top }
411439 Just OpenApiInteger -> bottom
412− { forNumber = singletonFormula (t `Snoc` IntegerType) $ MultipleOf 1 }
440+ { forNumber = singletonFormula IntegerType $ MultipleOf 1 }
413441 Just OpenApiString -> bottom
414442 { forString = top }
415443 Just OpenApiArray -> bottom
@@ -419,27 +447,27 @@ processSchema (Traced t Schema{..}) = do
419447
420448 let
421449 valueEnum A.Null = bottom
422− { forNull = singletonFormula (t `Snoc` EnumField) $ Exactly TNull }
450+ { forNull = singletonFormula EnumField $ Exactly TNull }
423451 valueEnum (A.Bool b) = bottom
424− { forBoolean = singletonFormula (t `Snoc` EnumField) $ Exactly $ TBool b }
452+ { forBoolean = singletonFormula EnumField $ Exactly $ TBool b }
425453 valueEnum (A.Number n) = bottom
426− { forNumber = singletonFormula (t `Snoc` EnumField) $ Exactly $ TNumber n }
454+ { forNumber = singletonFormula EnumField $ Exactly $ TNumber n }
427455 valueEnum (A.String s) = bottom
428− { forString = singletonFormula (t `Snoc` EnumField) $ Exactly $ TString s }
456+ { forString = singletonFormula EnumField $ Exactly $ TString s }
429457 valueEnum (A.Array a) = bottom
430− { forArray = singletonFormula (t `Snoc` EnumField) $ Exactly $ TArray a }
458+ { forArray = singletonFormula EnumField $ Exactly $ TArray a }
431459 valueEnum (A.Object o) = bottom
432− { forObject = singletonFormula (t `Snoc` EnumField) $ Exactly $ TObject o }
460+ { forObject = singletonFormula EnumField $ Exactly $ TObject o }
433461 enumClause <- case _schemaEnum of
434462 Nothing -> pure top
435− Just [] -> bottom <$ warn t (InvalidSchema "no items in enum")
463+ Just [] -> bottom <$ warn sch (InvalidSchema "no items in enum")
436464 Just xs -> pure $ joins (valueEnum <$> xs)
437465
438466 let
439467 maximumClause = case _schemaMaximum of
440468 Nothing -> top
441469 Just n -> top
442− { forNumber = singletonFormula (t `Snoc` MaximumFields) $ Maximum $
470+ { forNumber = singletonFormula MaximumFields $ Maximum $
443471 case _schemaExclusiveMaximum of
444472 Just True -> Exclusive n
445473 _ -> Inclusive n }
@@ -447,7 +475,7 @@ processSchema (Traced t Schema{..}) = do
447475 minimumClause = case _schemaMinimum of
448476 Nothing -> top
449477 Just n -> top
450− { forNumber = singletonFormula (t `Snoc` MinimumFields) $ Minimum $ Down $
478+ { forNumber = singletonFormula MinimumFields $ Minimum $ Down $
451479 case _schemaExclusiveMinimum of
452480 Just True -> Exclusive $ Down n
453481 _ -> Inclusive $ Down n }
@@ -455,72 +483,68 @@ processSchema (Traced t Schema{..}) = do
455483 multipleOfClause = case _schemaMultipleOf of
456484 Nothing -> top
457485 Just n -> top
458− { forNumber = singletonFormula (t `Snoc` MultipleOfField) $ MultipleOf n }
486+ { forNumber = singletonFormula MultipleOfField $ MultipleOf n }
459487
460488 formatClause <- case _schemaFormat of
461489 Nothing -> pure top
462490 Just f | f `elem` ["int32", "int64", "float", "double"] -> pure top
463− { forNumber = singletonFormula (t `Snoc` FormatField) $ NumberFormat f }
491+ { forNumber = singletonFormula FormatField $ NumberFormat f }
464492 Just f | f `elem` ["byte", "binary", "date", "date-time", "password"] -> pure top
465− { forString = singletonFormula (t `Snoc` FormatField) $ StringFormat f }
466− Just f -> top <$ warn t (NotSupported $ "Unknown format: " <> f)
493+ { forString = singletonFormula FormatField $ StringFormat f }
494+ Just f -> top <$ warn sch (NotSupported $ "Unknown format: " <> f)
467495
468496 let
469497 maxLengthClause = case _schemaMaxLength of
470498 Nothing -> top
471499 Just n -> top
472− { forString = singletonFormula (t `Snoc` MaxLengthField) $ MaxLength n }
500+ { forString = singletonFormula MaxLengthField $ MaxLength n }
473501
474502 minLengthClause = case _schemaMinLength of
475503 Nothing -> top
476504 Just n -> top
477− { forString = singletonFormula (t `Snoc` MinLengthField) $ MinLength n }
505+ { forString = singletonFormula MinLengthField $ MinLength n }
478506
479507 patternClause = case _schemaPattern of
480508 Nothing -> top
481509 Just p -> top
482− { forString = singletonFormula (t `Snoc` PatternField) $ Pattern p }
510+ { forString = singletonFormula PatternField $ Pattern p }
483511
484− itemsClause <- case _schemaItems of
512+ itemsClause <- case tracedItems sch of
485513 Nothing -> pure top
486− Just (OpenApiItemsObject rs) -> do
487− let trs = Traced (t `Snoc` ItemsStep) rs
488− f <- processRefSchema trs
489− pure top { forArray = singletonFormula (t `Snoc` ItemsField) $ Items f trs }
490− Just (OpenApiItemsArray _) -> top <$ warn t (NotSupported "array in items is not supported")
514+ Just (Left rs) -> do
515+ f <- processRefSchema rs
516+ pure top { forArray = singletonFormula ItemsField $ Items f rs }
517+ Just (Right _) -> top <$ warn sch (NotSupported "array in items is not supported")
491518
492519 let
493520 maxItemsClause = case _schemaMaxItems of
494521 Nothing -> top
495522 Just n -> top
496− { forArray = singletonFormula (t `Snoc` MaxItemsField) $ MaxItems n }
523+ { forArray = singletonFormula MaxItemsField $ MaxItems n }
497524
498525 minItemsClause = case _schemaMinItems of
499526 Nothing -> top
500527 Just n -> top
501− { forArray = singletonFormula (t `Snoc` MinItemsField) $ MinItems n }
528+ { forArray = singletonFormula MinItemsField $ MinItems n }
502529
503530 uniqueItemsClause = case _schemaUniqueItems of
504531 Just True -> top
505− { forArray = singletonFormula (t `Snoc` UniqueItemsField) UniqueItems }
532+ { forArray = singletonFormula UniqueItemsField UniqueItems }
506533 _ -> top
507534
508− (addProps, addPropSchema) <- case _schemaAdditionalProperties of
509− Just (AdditionalPropertiesSchema rs) -> do
510− let trs = Traced (t `Snoc` AdditionalPropertiesStep) rs
511− (,Just trs) <$> processRefSchema trs
512− Just (AdditionalPropertiesAllowed False) -> pure (bottom, Nothing)
513− _ -> pure (top, Just $ Traced (t `Snoc` AdditionalPropertiesStep) $ Inline mempty)
535+ (addProps, addPropSchema) <- case tracedAdditionalProperties sch of
536+ Just (Right rs) -> (,Just rs) <$> processRefSchema rs
537+ Just (Left False) -> pure (bottom, Nothing)
538+ _ -> pure (top, Just $ traced (ask sch `Snoc` AdditionalPropertiesStep) $ Inline mempty)
514539 propList <- forM (S.toList . S.fromList $ IOHM.keys _schemaProperties <> _schemaRequired) $ \k -> do
515− (f, sch) <- case IOHM.lookup k _schemaProperties of
516− Just rs -> do
517− let trs = Traced (t `Snoc` PropertiesStep k) rs
518− (,trs) <$> processRefSchema trs
519− Nothing -> pure (addProps, fromMaybe (Traced (t `Snoc` AdditionalPropertiesStep) $ Inline mempty) addPropSchema)
540+ (f, psch) <- case IOHM.lookup k $ tracedProperties sch of
541+ Just rs -> (,rs) <$> processRefSchema rs
542+ Nothing -> let fakeSchema = traced (ask sch `Snoc` AdditionalPropertiesStep) $ Inline mempty
520543 -- The mempty here is incorrect, but if addPropSchema was Nothing, then
521544 -- addProps is bottom, and k is in _schemaRequired. We handle this situation
522545 -- below and short-circuit the entire Properties condition to bottom
523− pure (k, Property (k `elem` _schemaRequired) f sch)
546+ in pure (addProps, fromMaybe fakeSchema addPropSchema)
547+ pure (k, Property (k `elem` _schemaRequired) f psch)
524548 let
525549 allBottom f = getAll $ foldType $ \ty -> case ty f of
526550 BottomFormula -> All True
@@ -537,21 +561,21 @@ processSchema (Traced t Schema{..}) = do
537561 = top -- if all fields are optional and have trivial schemata
538562 | otherwise
539563 = top
540− { forObject = singletonFormula (t `Snoc` PropertiesFields) $ Properties propMap addProps addPropSchema }
564+ { forObject = singletonFormula PropertiesFields $ Properties propMap addProps addPropSchema }
541565
542566 maxPropertiesClause = case _schemaMaxProperties of
543567 Nothing -> top
544568 Just n -> top
545− { forObject = singletonFormula (t `Snoc` MaxPropertiesField) $ MaxProperties n }
569+ { forObject = singletonFormula MaxPropertiesField $ MaxProperties n }
546570
547571 minPropertiesClause = case _schemaMinProperties of
548572 Nothing -> top
549573 Just n -> top
550− { forObject = singletonFormula (t `Snoc` MinPropertiesField) $ MinProperties n }
574+ { forObject = singletonFormula MinPropertiesField $ MinProperties n }
551575
552576 nullableClause
553577 | Just True <- _schemaNullable = bottom
554− { forNull = singletonFormula (t `Snoc` NullableField) $ Exactly TNull }
578+ { forNull = singletonFormula NullableField $ Exactly TNull }
555579 | otherwise = bottom
556580
557581 pure $ nullableClause \/ meets (allClauses <>
@@ -561,7 +585,7 @@ processSchema (Traced t Schema{..}) = do
561585 , uniqueItemsClause, propertiesClause, maxPropertiesClause, minPropertiesClause])
562586{- TODO: ReadOnly/WriteOnly -}
563587
564−checkOneOfDisjoint :: [Referenced Schema] -> ProcessM Bool
588+checkOneOfDisjoint :: [Traced OpenApi (Referenced Schema)] -> ProcessM Bool
565589checkOneOfDisjoint = const $ pure True -- TODO
566590
567591schemaToFormula
@@ -575,7 +599,7 @@ checkFormulas
575599 => HList xs
576600 -> Trace OpenApi Schema
577601 -> ProdCons (ForeachType (JsonFormula OpenApi), T.TracePrefixTree SubtreeCheckIssue OpenApi)
578− -> CompatFormula Schema ()
602+ -> CompatFormula ()
579603checkFormulas env tr (ProdCons (fp, ep) (fc, ec)) =
580604 case T.toList ep ++ T.toList ec of
581605 issues@(_:_) -> F.for_ issues $ \(AnItem t (SubtreeCheckIssue e)) -> issueAtTrace t e
@@ -613,13 +637,13 @@ checkFormulas env tr (ProdCons (fp, ep) (fc, ec)) =
613637 (DNF pss, SingleConjunct cs) -> F.for_ pss $ \(Conjunct ps) -> do
614638 F.for_ cs $ checkImplication env ps -- avoid disjuntion if there's only one conjunct
615639 (DNF pss, DNF css) -> F.for_ pss $ \(Conjunct ps) -> do
616− anyOfM tr (SubtreeCheckIssue $ NoMatchingCondition $ SomeCondition . getTraced <$> ps)
640+ anyOfM tr (NoMatchingCondition $ SomeCondition <$> ps)
617641 [F.for_ cs $ checkImplication env ps | Conjunct cs <- S.toList css]
618642
619643checkContradiction
620644 :: Trace OpenApi Schema
621645 -> [Traced OpenApi (Condition t)]
622− -> CompatFormula s ()
646+ -> CompatFormula ()
623647checkContradiction tr _ = issueAtTrace tr NoContradiction -- TODO
624648
625649checkImplication
@@ -627,96 +651,93 @@ checkImplication
627651 => HList xs
628652 -> [Traced OpenApi (Condition t)]
629653 -> Traced OpenApi (Condition t)
630− -> CompatFormula s ()
631−checkImplication env prods (Traced t cons) = case findExactly prods of
654+ -> CompatFormula ()
655+checkImplication env prods cons = case findExactly prods of
632656 Just e
633− | all (satisfiesTyped e) (getTraced <$> prods) ->
634− if satisfiesTyped e cons then pure ()
635− else issueAtTrace t (EnumDoesntSatisfy e)
657+ | all (satisfiesTyped e) (extract <$> prods) ->
658+ if satisfiesTyped e $ extract cons then pure ()
659+ else issueAt cons (EnumDoesntSatisfy e)
636660 | otherwise -> pure () -- vacuously true
637− Nothing -> case cons of
661+ Nothing -> case extract cons of
638662 -- the above code didn't catch it, so there's no Exactly condition on the lhs
639− Exactly e -> issueAtTrace t (NoMatchingEnum e)
663+ Exactly e -> issueAt cons (NoMatchingEnum e)
640664 Maximum m -> case findRelevant min (\case Maximum m' -> Just m'; _ -> Nothing) prods of
641665 Just m' -> if m' <= m then pure ()
642− else issueAtTrace t (MatchingMaximumWeak m m')
643− Nothing -> issueAtTrace t (NoMatchingMaximum m)
666+ else issueAt cons (MatchingMaximumWeak m m')
667+ Nothing -> issueAt cons (NoMatchingMaximum m)
644668 Minimum m -> case findRelevant max (\case Minimum m' -> Just m'; _ -> Nothing) prods of
645669 Just m' -> if m' >= m then pure ()
646− else issueAtTrace t (MatchingMinimumWeak (coerce m) (coerce m'))
647− Nothing -> issueAtTrace t (NoMatchingMinimum (coerce m))
670+ else issueAt cons (MatchingMinimumWeak (coerce m) (coerce m'))
671+ Nothing -> issueAt cons (NoMatchingMinimum (coerce m))
648672 MultipleOf m -> case findRelevant lcmScientific (\case MultipleOf m' -> Just m'; _ -> Nothing) prods of
649673 Just m' -> if lcmScientific m m' == m' then pure ()
650− else issueAtTrace t (MatchingMultipleOfWeak m m')
651− Nothing -> issueAtTrace t (NoMatchingMultipleOf m)
652− NumberFormat f -> if any (\case NumberFormat f' -> f == f'; _ -> False) $ getTraced <$> prods
653− then pure () else issueAtTrace t (NoMatchingFormat f)
674+ else issueAt cons (MatchingMultipleOfWeak m m')
675+ Nothing -> issueAt cons (NoMatchingMultipleOf m)
676+ NumberFormat f -> if any (\case NumberFormat f' -> f == f'; _ -> False) $ extract <$> prods
677+ then pure () else issueAt cons (NoMatchingFormat f)
654678 MaxLength m -> case findRelevant min (\case MaxLength m' -> Just m'; _ -> Nothing) prods of
655679 Just m' -> if m' <= m then pure ()
656− else issueAtTrace t (MatchingMaxLengthWeak m m')
657− Nothing -> issueAtTrace t (NoMatchingMaxLength m)
680+ else issueAt cons (MatchingMaxLengthWeak m m')
681+ Nothing -> issueAt cons (NoMatchingMaxLength m)
658682 MinLength m -> case findRelevant max (\case MinLength m' -> Just m'; _ -> Nothing) prods of
659683 Just m' -> if m' >= m then pure ()
660− else issueAtTrace t (MatchingMinLengthWeak m m')
661− Nothing -> issueAtTrace t (NoMatchingMinLength m)
662− Pattern p -> if any (\case Pattern p' -> p == p'; _ -> False) $ getTraced <$> prods
663− then pure () else issueAtTrace t (NoMatchingPattern p)
664− StringFormat f -> if any (\case StringFormat f' -> f == f'; _ -> False) $ getTraced <$> prods
665− then pure () else issueAtTrace t (NoMatchingFormat f)
666− Items _ (Traced t' cons') -> case findRelevant (<>) (\case Items _ rs -> Just (rs NE.:| []); _ -> Nothing) prods of
667− Just (rs NE.:| []) -> localTrace' (ProdCons (getTrace rs) t') $ checkCompatibility env $ ProdCons (getTraced rs) cons'
684+ else issueAt cons (MatchingMinLengthWeak m m')
685+ Nothing -> issueAt cons (NoMatchingMinLength m)
686+ Pattern p -> if any (\case Pattern p' -> p == p'; _ -> False) $ extract <$> prods
687+ then pure () else issueAt cons (NoMatchingPattern p)
688+ StringFormat f -> if any (\case StringFormat f' -> f == f'; _ -> False) $ extract <$> prods
689+ then pure () else issueAt cons (NoMatchingFormat f)
690+ Items _ cons' -> case findRelevant (<>) (\case Items _ rs -> Just (rs NE.:| []); _ -> Nothing) prods of
691+ Just (rs NE.:| []) -> checkCompatibility env $ ProdCons rs cons'
668692 Just rs -> do
669− let sch = Inline mempty { _schemaAllOf = Just . NE.toList $ getTraced <$> rs }
670− localTrace' (pure t' {- TODO: what? -}) $ checkCompatibility env $ ProdCons sch cons'
671− Nothing -> issueAtTrace t NoMatchingItems
693+ let sch = Inline mempty { _schemaAllOf = Just . NE.toList $ extract <$> rs }
694+ checkCompatibility env $ ProdCons (traced (ask $ NE.head rs) sch) cons' -- TODO: bad trace
695+ Nothing -> issueAt cons NoMatchingItems
672696 MaxItems m -> case findRelevant min (\case MaxItems m' -> Just m'; _ -> Nothing) prods of
673697 Just m' -> if m' <= m then pure ()
674− else issueAtTrace t (MatchingMaxItemsWeak m m')
675− Nothing -> issueAtTrace t (NoMatchingMaxItems m)
698+ else issueAt cons (MatchingMaxItemsWeak m m')
699+ Nothing -> issueAt cons (NoMatchingMaxItems m)
676700 MinItems m -> case findRelevant max (\case MinItems m' -> Just m'; _ -> Nothing) prods of
677701 Just m' -> if m' >= m then pure ()
678− else issueAtTrace t (MatchingMinItemsWeak m m')
679− Nothing -> issueAtTrace t (NoMatchingMinItems m)
680− UniqueItems -> if any ((== UniqueItems) . getTraced) prods then pure ()
681− else issueAtTrace t NoMatchingUniqueItems
702+ else issueAt cons (MatchingMinItemsWeak m m')
703+ Nothing -> issueAt cons (NoMatchingMinItems m)
704+ UniqueItems -> if any (== UniqueItems) $ extract <$> prods then pure ()
705+ else issueAt cons NoMatchingUniqueItems
682706 Properties props _ madd -> case findRelevant (<>) (\case Properties props' _ madd' -> Just $ (props', madd') NE.:| []; _ -> Nothing) prods of
683707 Just ((props', madd') NE.:| []) -> do
684708 F.for_ (S.fromList $ M.keys props <> M.keys props') $ \k -> do
685− let
686− go sch' sch = let schs = ProdCons sch' sch
687− in localTrace' (getTrace <$> schs) $ checkCompatibility env $ getTraced <$> schs
709+ let go sch sch' = checkCompatibility env (ProdCons sch sch')
688710 case (M.lookup k props', madd', M.lookup k props, madd) of
689711 (Nothing, Nothing, _, _) -> pure () -- vacuously
690− (_, _, Nothing, Nothing) -> issueAtTrace t (UnexpectedProperty k)
712+ (_, _, Nothing, Nothing) -> issueAt cons (UnexpectedProperty k)
691713 (Just p', _, Just p, _) -> go (propRefSchema p') (propRefSchema p)
692714 (Nothing, Just add', Just p, _) -> go add' (propRefSchema p)
693715 (Just p', _, Nothing, Just add) -> go (propRefSchema p') add
694716 (Nothing, Just _, Nothing, Just _) -> pure ()
695717 case (maybe False propRequired $ M.lookup k props', maybe False propRequired $ M.lookup k props) of
696− (False, True) -> issueAtTrace t (PropertyNowRequired k)
718+ (False, True) -> issueAt cons (PropertyNowRequired k)
697719 _ -> pure ()
698720 pure ()
699721 case (madd', madd) of
700722 (Nothing, _) -> pure () -- vacuously
701− (_, Nothing) -> issueAtTrace t NoAdditionalProperties
702− (Just add', Just add) -> let schs = ProdCons add' add
703− in localTrace' (getTrace <$> schs) $ checkCompatibility env $ getTraced <$> schs
723+ (_, Nothing) -> issueAt cons NoAdditionalProperties
724+ (Just add', Just add) -> checkCompatibility env (ProdCons add' add)
704725 pure ()
705− Nothing -> issueAtTrace t NoMatchingProperties
726+ Nothing -> issueAt cons NoMatchingProperties
706727 MaxProperties m -> case findRelevant min (\case MaxProperties m' -> Just m'; _ -> Nothing) prods of
707728 Just m' -> if m' <= m then pure ()
708− else issueAtTrace t (MatchingMaxPropertiesWeak m m')
709− Nothing -> issueAtTrace t (NoMatchingMaxProperties m)
729+ else issueAt cons (MatchingMaxPropertiesWeak m m')
730+ Nothing -> issueAt cons (NoMatchingMaxProperties m)
710731 MinProperties m -> case findRelevant max (\case MinProperties m' -> Just m'; _ -> Nothing) prods of
711732 Just m' -> if m' >= m then pure ()
712− else issueAtTrace t (MatchingMinPropertiesWeak m m')
713− Nothing -> issueAtTrace t (NoMatchingMinProperties m)
733+ else issueAt cons (MatchingMinPropertiesWeak m m')
734+ Nothing -> issueAt cons (NoMatchingMinProperties m)
714735 where
715− findExactly (Traced _ (Exactly x):_) = Just x
736+ findExactly ((extract -> Exactly x):_) = Just x
716737 findExactly (_:xs) = findExactly xs
717738 findExactly [] = Nothing
718− findRelevant combine extract
719− = fmap (foldr1 combine) . NE.nonEmpty . mapMaybe (extract . getTraced)
739+ findRelevant combine extr
740+ = fmap (foldr1 combine) . NE.nonEmpty . mapMaybe (extr . extract)
720741 lcmScientific (toRational -> a) (toRational -> b)
721742 = fromRational $ lcm (numerator a) (numerator b) % gcd (denominator a) (denominator b)
722743
@@ -753,9 +774,7 @@ instance Typeable t => Subtree (Condition t) where
753774 deriving stock (Eq, Ord, Show)
754775 type CheckEnv (Condition t) = CheckEnv Schema
755776 normalizeTrace = undefined
756− checkCompatibility env conds = withTrace $ \traces -> do
757− case Traced <$> traces <*> conds of
758− ProdCons prod cons -> checkImplication env [prod] cons
777+ checkCompatibility env pc = checkImplication env [producer pc] (consumer pc)
759778
760779instance Subtree Schema where
761780 data CheckIssue Schema
@@ -765,18 +784,16 @@ instance Subtree Schema where
765784 | NoContradiction
766785 deriving stock (Eq, Ord, Show)
767786 type CheckEnv Schema = '[ProdCons (Definitions Schema)]
768− checkCompatibility env schs = withTrace $ \traces -> do
787+ checkCompatibility env schs = do
769788 let defs = getH env
770− checkFormulas env (producer traces) $ schemaToFormula <$> defs <*> (Traced <$> traces <*> schs)
789+ checkFormulas env (ask $ producer schs) $ schemaToFormula <$> defs <*> schs
771790
772791instance Subtree (Referenced Schema) where
773792 data CheckIssue (Referenced Schema)
774793 deriving stock (Eq, Ord, Show)
775794 type CheckEnv (Referenced Schema) = CheckEnv Schema
776− checkCompatibility env refs = withTrace $ \traces -> do
795+ checkCompatibility env refs = do
777796 let
778797 defs = getH env
779798 schs = dereference <$> defs <*> refs
780− schs' = retrace <$> traces <*> schs
781− localTrace (getTrace <$> schs) $ do
782− checkFormulas env (producer $ getTrace <$> schs') $ schemaToFormula <$> defs <*> schs'
799+ checkFormulas env (ask $ producer schs) $ schemaToFormula <$> defs <*> schs