1e7e283 · typeable/compaREST

git.iko.soy/typeable/compaREST

on master help sign in

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

1e7e283mniip5 years ago

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

compare with master

unifiedsplit

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

10import Data.Aeson

11import Data.Kind

12import Data.Text as T

13+import Data.Typeable

13import OpenAPI.Checker.Paths

14import OpenAPI.Checker.Paths

15-- | Kind

16-- | Kind

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

37 where

38 where

38 data Behave a b

39 data Behave a b

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

41 data Issue l :: Type

42 data Issue l :: Type

42 describeIssue :: Issue l -> Text

43 describeIssue :: Issue l -> Text

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

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

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

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

7 , errors

8 , calculate

9 , maxFixpoint

10+ , mapErrors

10 ) where

11 ) where

12import Data.Kind

13import Data.Kind

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

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

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

30 -- both not 'Result'

31 -- both not 'Result'

31 SelectFirst :: NE.NonEmpty (SomeFormulaF b)

32 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

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

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

34 -- 'SelectFirst'

35 -- 'SelectFirst'

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

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

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

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

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

41mkApply f x h = Apply f x h

42mkApply f x h = Apply f x h

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

44mkSelectFirst fs allE h = case foldMap check fs of

45mkSelectFirst fs allE h = case foldMap check fs of

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

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

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

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

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

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

48 where

49 where

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

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

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

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

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

81 f <*> x = mkApply f x id

82 f <*> x = mkApply f x id

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

84eitherOf :: [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

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

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

87calculate (Result x) = Right x

88calculate (Result x) = Right x

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

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

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

99 Left _ -> go rs

100 Left _ -> go rs

100 Right x -> Right (h x)

101 Right x -> Right (h x)

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

102+ go [] = Left e

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

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

103

104

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

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

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

115 go v@(Variable _ _) = v

116 go v@(Variable _ _) = v

116 goSF :: SomeFormulaF a -> SomeFormulaF a

117 goSF :: SomeFormulaF a -> SomeFormulaF a

117 goSF (SomeFormulaF x) = SomeFormulaF (go x)

118 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

25 fail "Exiting"

26 Right s -> pure s

27 Right s -> pure s

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

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

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

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

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

31 output = case outputMode opts of

32 StdoutMode -> BSC.putStrLn

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

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

3module OpenAPI.Checker.Subtree

4 ( Steppable (..)

5 , Step (..)

6+ , TraceRoot

6 , Trace

7 , Trace

7 , Traced

8 , Traced

8 , Traced'

9 , Traced'

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

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

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

70 data Step a b :: Type

71 data Step a b :: Type

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+

72−type Trace = Paths Step OpenApi

81+type Trace = Paths Step TraceRoot

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

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

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

117

126

118type SemanticCompatFormula = CompatFormula' Behave AnIssue 'APILevel

127type SemanticCompatFormula = CompatFormula' Behave AnIssue 'APILevel

119

128

120−type StructuralCompatFormula = CompatFormula' UnitQuiver Proxy ()

129+type StructuralCompatFormula = CompatFormula' VoidQuiver Proxy ()

121

130

122−data UnitQuiver a b where

131+data VoidQuiver a b where

123− UnitQuiver :: UnitQuiver () ()

124

132

125−deriving stock instance Eq (UnitQuiver a b)

133+deriving stock instance Eq (VoidQuiver a b)

126

134

127−deriving stock instance Ord (UnitQuiver a b)

135+deriving stock instance Ord (VoidQuiver a b)

128

136

129−deriving stock instance Show (UnitQuiver a b)

137+deriving stock instance Show (VoidQuiver a b)

130

138

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

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

132 type CheckEnv t :: [Type]

140 type CheckEnv t :: [Type]

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

155 -> Behavior (SubtreeLevel t)

163 -> Behavior (SubtreeLevel t)

156 -> ProdCons (Traced t)

164 -> ProdCons (Traced t)

157 -> SemanticCompatFormula ()

165 -> SemanticCompatFormula ()

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

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

159 case runCompatFormula $ checkSubstructure e pc of

167 case runCompatFormula $ checkSubstructure e pc of

160 Left _ -> checkSemanticCompatibility e bhv pc

168 Left _ -> checkSemanticCompatibility e bhv pc

161 Right () -> pure ()

169 Right () -> pure ()

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

165 => HList xs

173 => HList xs

166 -> ProdCons (Traced t)

174 -> ProdCons (Traced t)

167 -> StructuralCompatFormula ()

175 -> StructuralCompatFormula ()

168−checkSubstructure e = memo StructuralMemoKey $ checkStructuralCompatibility e

176+checkSubstructure e = memo Root StructuralMemoKey $ checkStructuralCompatibility e

169

177

170structuralMaybe

178structuralMaybe

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

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

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

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

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

261

269

262structuralIssue :: StructuralCompatFormula a

270structuralIssue :: StructuralCompatFormula a

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

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

264

272

265anyOfAt

273anyOfAt

266 :: Issuable l

274 :: Issuable l

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

283 }

291 }

284

292

285memo

293memo

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

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

295+ => Paths q r l

287− => MemoKey

296+ -> MemoKey

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

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

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

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

299+memo bhv k f pc = Compose $ do

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

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'

291

305

292data MemoKey = SemanticMemoKey | StructuralMemoKey

306data MemoKey = SemanticMemoKey | StructuralMemoKey

293 deriving stock (Eq, Ord)

307 deriving stock (Eq, Ord)

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

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

21 "trace-tree.yaml"

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

23 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:

5 InPayload:

6 PayloadSchema:

7 OfType Object: UnexpectedProperty "property2"

8+ WithStatusCode 200:

9+ ResponsePayload:

10+ PayloadSchema:

11+ OfType Object: PropertyNowRequired "property2"