1e7e283 · typeable/compaREST

git.iko.soy/typeable/compaREST

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

* Re-emit memoized errors at different behaviors * Fix client/server vs server/client memoization

commit1e7e283b2c660a2471acca5ce133d991d1d1d61b authormniip <mniip@users.noreply.github.com> dateFri 28 May 2021, 14:45 (5 years ago) parentb5ed0cb

6 files changed+54−22

compare with master

unifiedsplit

src/OpenAPI/Checker/Behavior.hs+2−1 src/OpenAPI/Checker/Formula.hs+13−5 src/OpenAPI/Checker/Run.hs+2−2 src/OpenAPI/Checker/Subtree.hs+27−13 test/Spec/Golden/TraceTree.hs+6−1 test/golden/common/property-removed/trace-tree.yaml+4

src/OpenAPI/Checker/Behavior.hs+2−1

@@ -10,6 +10,7 @@ where

1010import Data.Aeson

1111import Data.Kind

1212import Data.Text as T

13+import Data.Typeable

1314import OpenAPI.Checker.Paths

1415

1516-- | Kind

@@ -37,7 +38,7 @@ class

3738 where

3839 data Behave a b

3940

40−class (Ord (Issue l), Show (Issue l)) => Issuable (l :: BehaviorLevel) where

41+class (Typeable l, Ord (Issue l), Show (Issue l)) => Issuable (l :: BehaviorLevel) where

4142 data Issue l :: Type

4243 describeIssue :: Issue l -> Text

4344 describeIssue = T.pack . show -- TODO: remove this default

src/OpenAPI/Checker/Formula.hs+13−5

@@ -7,6 +7,7 @@ module OpenAPI.Checker.Formula

77 , errors

88 , calculate

99 , maxFixpoint

10+ , mapErrors

1011 ) where

1112

1213import Data.Kind

@@ -29,7 +30,7 @@ data FormulaF (q :: k -> k -> Type) (f :: k -> Type) (r :: k) (a :: Type) where

2930 -- ^ invariant: at least one of LHS and RHS is not 'Errors', and they are

3031 -- both not 'Result'

3132 SelectFirst :: NE.NonEmpty (SomeFormulaF b)

32− -> !(AnItem q f r) -> (b -> a) -> FormulaF q f r a

33+ -> !(P.PathsPrefixTree q f r) -> (b -> a) -> FormulaF q f r a

3334 -- ^ invariant: the list doesn't contain any 'Result's, 'Errors' or

3435 -- 'SelectFirst'

3536 Variable :: !VarRef -> a -> FormulaF q f r a

@@ -40,11 +41,11 @@ mkApply f (Result x) h = h . ($ x) <$> f

4041mkApply (Errors e1) (Errors e2) _ = Errors (e1 <> e2)

4142mkApply f x h = Apply f x h

4243

43−mkSelectFirst :: [SomeFormulaF b] -> AnItem q f r -> (b -> a) -> FormulaF q f r a

44+mkSelectFirst :: [SomeFormulaF b] -> P.PathsPrefixTree q f r -> (b -> a) -> FormulaF q f r a

4445mkSelectFirst fs allE h = case foldMap check fs of

4546 (First (Just x), _) -> Result (h x)

4647 (First Nothing, x:xs) -> SelectFirst (x NE.:| xs) allE h

47− (First Nothing, []) -> Errors $ P.singleton allE

48+ (First Nothing, []) -> Errors allE

4849 where

4950 check (SomeFormulaF (Result x)) = (First (Just x), mempty)

5051 check (SomeFormulaF (Errors _)) = (mempty, mempty)

@@ -81,7 +82,7 @@ instance Applicative (FormulaF q f r) where

8182 f <*> x = mkApply f x id

8283

8384eitherOf :: [FormulaF q' f' r' a] -> AnItem q f r -> FormulaF q f r a

84−eitherOf fs allE = mkSelectFirst (map SomeFormulaF fs) allE id

85+eitherOf fs allE = mkSelectFirst (map SomeFormulaF fs) (P.singleton allE) id

8586

8687calculate :: FormulaF q f r a -> Either (P.PathsPrefixTree q f r) a

8788calculate (Result x) = Right x

@@ -98,7 +99,7 @@ calculate (SelectFirst xs e h) = go (NE.toList xs)

9899 go (SomeFormulaF r:rs) = case calculate r of

99100 Left _ -> go rs

100101 Right x -> Right (h x)

101− go [] = Left $ P.singleton e

102+ go [] = Left e

102103calculate (Variable i _) = error $ "Unknown variable " <> show i

103104

104105-- Approximate for now. Answers yes/no correctly, but the error lists aren't

@@ -115,3 +116,10 @@ maxFixpoint i = go

115116 go v@(Variable _ _) = v

116117 goSF :: SomeFormulaF a -> SomeFormulaF a

117118 goSF (SomeFormulaF x) = SomeFormulaF (go x)

119+

120+mapErrors :: (P.PathsPrefixTree q f r -> P.PathsPrefixTree q' f' r') -> FormulaF q f r a -> FormulaF q' f' r' a

121+mapErrors _ (Result x) = Result x

122+mapErrors m (Errors e) = Errors $ m e

123+mapErrors m (Apply f x h) = mkApply (mapErrors m f) (mapErrors m x) h

124+mapErrors m (SelectFirst fs e h) = mkSelectFirst (NE.toList fs) (m e) h

125+mapErrors _ (Variable i x) = Variable i x

src/OpenAPI/Checker/Run.hs+2−2

@@ -25,8 +25,8 @@ runChecker = do

2525 fail "Exiting"

2626 Right s -> pure s

2727 Right s -> pure s

28− a <- traced Root <$> parseSchema (clientFile opts)

29− b <- traced Root <$> parseSchema (serverFile opts)

28+ a <- traced (step ClientSchema) <$> parseSchema (clientFile opts)

29+ b <- traced (step ServerSchema) <$> parseSchema (serverFile opts)

3030 let report = runCompatFormula $ checkCompatibility HNil Root (ProdCons a b)

3131 output = case outputMode opts of

3232 StdoutMode -> BSC.putStrLn

src/OpenAPI/Checker/Subtree.hs+27−13

@@ -3,6 +3,7 @@

33module OpenAPI.Checker.Subtree

44 ( Steppable (..)

55 , Step (..)

6+ , TraceRoot

67 , Trace

78 , Traced

89 , Traced'

@@ -69,7 +70,15 @@ class

6970 -- | How to get from an @a@ node to a @b@ node

7071 data Step a b :: Type

7172

72−type Trace = Paths Step OpenApi

73+data TraceRoot

74+

75+instance Steppable TraceRoot OpenApi where

76+ data Step TraceRoot OpenApi

77+ = ClientSchema

78+ | ServerSchema

79+ deriving stock (Eq, Ord, Show)

80+

81+type Trace = Paths Step TraceRoot

7382

7483type Traced' a b = Env (Trace a) b

7584

@@ -117,16 +126,15 @@ type CompatFormula' q f r = Compose CompatM (FormulaF q f r)

117126

118127type SemanticCompatFormula = CompatFormula' Behave AnIssue 'APILevel

119128

120−type StructuralCompatFormula = CompatFormula' UnitQuiver Proxy ()

129+type StructuralCompatFormula = CompatFormula' VoidQuiver Proxy ()

121130

122−data UnitQuiver a b where

123− UnitQuiver :: UnitQuiver () ()

131+data VoidQuiver a b where

124132

125−deriving stock instance Eq (UnitQuiver a b)

133+deriving stock instance Eq (VoidQuiver a b)

126134

127−deriving stock instance Ord (UnitQuiver a b)

135+deriving stock instance Ord (VoidQuiver a b)

128136

129−deriving stock instance Show (UnitQuiver a b)

137+deriving stock instance Show (VoidQuiver a b)

130138

131139class (Typeable t, Issuable (SubtreeLevel t)) => Subtree (t :: Type) where

132140 type CheckEnv t :: [Type]

@@ -155,7 +163,7 @@ checkCompatibility

155163 -> Behavior (SubtreeLevel t)

156164 -> ProdCons (Traced t)

157165 -> SemanticCompatFormula ()

158−checkCompatibility e bhv = memo SemanticMemoKey $ \pc ->

166+checkCompatibility e bhv = memo bhv SemanticMemoKey $ \pc ->

159167 case runCompatFormula $ checkSubstructure e pc of

160168 Left _ -> checkSemanticCompatibility e bhv pc

161169 Right () -> pure ()

@@ -165,7 +173,7 @@ checkSubstructure

165173 => HList xs

166174 -> ProdCons (Traced t)

167175 -> StructuralCompatFormula ()

168−checkSubstructure e = memo StructuralMemoKey $ checkStructuralCompatibility e

176+checkSubstructure e = memo Root StructuralMemoKey $ checkStructuralCompatibility e

169177

170178structuralMaybe

171179 :: (Subtree a, HasAll (CheckEnv a) xs)

@@ -260,7 +268,7 @@ issueAt :: Issuable l => Paths q r l -> Issue l -> CompatFormula' q AnIssue r a

260268issueAt xs issue = Compose $ pure $ anError $ AnItem xs $ AnIssue issue

261269

262270structuralIssue :: StructuralCompatFormula a

263−structuralIssue = Compose $ pure $ anError $ AnItem (step UnitQuiver) Proxy

271+structuralIssue = Compose $ pure $ anError $ AnItem Root Proxy

264272

265273anyOfAt

266274 :: Issuable l

@@ -283,11 +291,17 @@ fixpointKnot =

283291 }

284292

285293memo

286− :: (Typeable (r :: k), Typeable q, Typeable f, Typeable k, Typeable a)

287− => MemoKey

294+ :: (Typeable (l :: k), Typeable q, Typeable f, Typeable k, Typeable a)

295+ => Paths q r l

296+ -> MemoKey

288297 -> (ProdCons (Traced a) -> CompatFormula' q f r ())

289298 -> (ProdCons (Traced a) -> CompatFormula' q f r ())

290−memo k f pc = Compose $ memoWithKnot fixpointKnot (getCompose $ f pc) (k, ask <$> pc)

299+memo bhv k f pc = Compose $ do

300+ formula' <- memoWithKnot fixpointKnot (do

301+ formula <- getCompose $ f pc

302+ pure $ mapErrors (P.filter bhv) formula

303+ ) (k, ask <$> pc)

304+ pure $ mapErrors (P.embed bhv) formula'

291305

292306data MemoKey = SemanticMemoKey | StructuralMemoKey

293307 deriving stock (Eq, Ord)

test/Spec/Golden/TraceTree.hs+6−1

@@ -21,4 +21,9 @@ tests =

2121 "trace-tree.yaml"

2222 ("a.yaml", "b.yaml")

2323 Yaml.decodeFileThrow

24− (runCompatFormula . checkCompatibility HNil Root . fmap (traced Root) . uncurry ProdCons)

24+ (runCompatFormula . checkCompatibility HNil Root . toPC)

25+ where

26+ toPC (client, server) = ProdCons

27+ { producer = traced (step ClientSchema) client

28+ , consumer = traced (step ServerSchema) server

29+ }

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

@@ -5,3 +5,7 @@ Left:

55 InPayload:

66 PayloadSchema:

77 OfType Object: UnexpectedProperty "property2"

8+ WithStatusCode 200:

9+ ResponsePayload:

10+ PayloadSchema:

11+ OfType Object: PropertyNowRequired "property2"