git.iko.soy/typeable/compaREST
on master help sign in
Dropped unused modules (#25)
7dface8iko
openapi-diff.cabal+6−8
compare with master
unifiedsplit
@@ -46,6 +46,9 @@ common common-options
46 , transformers
46 , transformers
47 , typerep-map
47 , typerep-map
48 , yaml
48 , yaml
49+ , unordered-containers
50+ , vector
51+ , bytestring
49
52
50 default-extensions: ApplicativeDo
53 default-extensions: ApplicativeDo
51 , BangPatterns
54 , BangPatterns
@@ -84,25 +87,21 @@ common common-options
84 , TypeOperators
87 , TypeOperators
85 , UndecidableInstances
88 , UndecidableInstances
86 , ViewPatterns
89 , ViewPatterns
90+ , QuantifiedConstraints
87
91
88library
92library
89 import: common-options
93 import: common-options
90 hs-source-dirs: src
94 hs-source-dirs: src
91− exposed-modules: OpenAPI.Checker.Aux
92− , Data.HList
95+ exposed-modules: Data.HList
93 , OpenAPI.Checker.Formula
96 , OpenAPI.Checker.Formula
94 , OpenAPI.Checker.Memo
97 , OpenAPI.Checker.Memo
95 , OpenAPI.Checker.Options
98 , OpenAPI.Checker.Options
96 , OpenAPI.Checker.Orphans
99 , OpenAPI.Checker.Orphans
97 , OpenAPI.Checker.References
100 , OpenAPI.Checker.References
98− , OpenAPI.Checker.Report
99 , OpenAPI.Checker.Run
101 , OpenAPI.Checker.Run
100 , OpenAPI.Checker.Subtree
102 , OpenAPI.Checker.Subtree
101 , OpenAPI.Checker.Trace
103 , OpenAPI.Checker.Trace
102 , OpenAPI.Checker.TracePrefixTree
104 , OpenAPI.Checker.TracePrefixTree
103− , OpenAPI.Checker.Validate
104− , OpenAPI.Checker.Validate.Dereference
105− , OpenAPI.Checker.Validate.Monad
106 , OpenAPI.Checker.Validate.OpenApi
105 , OpenAPI.Checker.Validate.OpenApi
107 , OpenAPI.Checker.Validate.Operation
106 , OpenAPI.Checker.Validate.Operation
108 , OpenAPI.Checker.Validate.Param
107 , OpenAPI.Checker.Validate.Param
@@ -123,9 +122,8 @@ test-suite openapi-diff-test
123 hs-source-dirs: test
122 hs-source-dirs: test
124 main-is: Spec.hs
123 main-is: Spec.hs
125 other-modules:
124 other-modules:
126− Spec.Golden.Report
127 Spec.Golden.Extra
125 Spec.Golden.Extra
128− Spec.Golden.ReportTree
126+ Spec.Golden.TraceTree
129 build-depends:
127 build-depends:
130 , openapi-diff
128 , openapi-diff
131 , tasty-golden
129 , tasty-golden
src/OpenAPI/Checker/Aux.hsdeleted−7
@@ -1,7 +0,0 @@
1−module OpenAPI.Checker.Aux where
2−
3−import Data.OpenApi.Internal
4−
5−-- | Megre servers from parent (like PathItem) and child (like Operation)
6−mergeServers :: [Server] -> [Server] -> [Server]
7−mergeServers parent child = (error "FIXME: not implemented")
src/OpenAPI/Checker/Orphans.hs+1−1
@@ -12,4 +12,4 @@ instance Typeable a => Steppable (Referenced a) a where
12 data Step (Referenced a) a
12 data Step (Referenced a) a
13 = InlineStep
13 = InlineStep
14 | ReferencedStep Reference
14 | ReferencedStep Reference
15− deriving (Eq, Ord)
15+ deriving (Eq, Ord, Show)
src/OpenAPI/Checker/Report.hsdeleted−118
@@ -1,118 +0,0 @@
1−module OpenAPI.Checker.Report where
2−
3−import Data.Aeson
4−import Data.Aeson.Types
5−import qualified Data.Attoparsec.Text as A
6−import Data.Functor
7−import Data.Map.Strict as M
8−import Data.Maybe
9−import Data.Monoid.Generic
10−import Data.OpenApi.Internal
11−import Data.Text (Text)
12−import Deriving.Aeson.Stock
13−import OpenAPI.Checker.Validate.Monad
14−import Prelude as P
15−
16−printReport :: Report -> IO ()
17−printReport = error "FIXME: printReport not implemented"
18−
19−class HasUnsupportedFeature x where
20− hasUnsupportedFeature :: x -> Bool
21−
22−data Report = Report
23− { status :: Status
24− , tree :: ReportTree
25− }
26− deriving stock (Eq, Ord, Show, Generic)
27− deriving (ToJSON, FromJSON) via Snake Report
28−
29−instance HasUnsupportedFeature Report
30−
31−instance HasUnsupportedFeature x => HasUnsupportedFeature (Either e x) where
32− hasUnsupportedFeature (Left _) = False
33− hasUnsupportedFeature (Right x) = hasUnsupportedFeature x
34−
35−data Status = Success | Fail Text
36− deriving stock (Eq, Ord, Show, Generic)
37− deriving (ToJSON, FromJSON) via Snake Status
38−
39−type Path = FilePath -- From the library
40−
41−newtype ReportTree = ReportTree
42− { paths :: Map Path (Errorable PathItemTree)
43− }
44− deriving stock (Show, Generic)
45− deriving newtype (Eq, Ord, Semigroup, Monoid)
46− deriving (ToJSON, FromJSON) via Snake ReportTree
47−
48−instance HasUnsupportedFeature ReportTree
49−
50−data PathItemTree = PathItemTree
51− { operations :: Map OperationName (Errorable OperationTree)
52− , server :: Maybe (Errorable ServerTree)
53− }
54− deriving stock (Eq, Ord, Show, Generic)
55− deriving (ToJSON, FromJSON) via Snake PathItemTree
56−
57−instance Semigroup PathItemTree where
58− (<>) = genericMappend
59−
60−instance Monoid PathItemTree where
61− mempty = genericMempty
62−
63−instance Nested PathItemTree where
64− type Parent PathItemTree = ReportTree
65− type Key PathItemTree = Path
66− nest key p = ReportTree $ M.singleton key p
67−
68−data OperationName
69− = Get | Put | Post | Delete | Options | Head | Patch | Trace
70− deriving (Eq, Ord, Show, Generic)
71− deriving (ToJSON, FromJSON) via Snake OperationName
72− deriving anyclass (ToJSONKey, FromJSONKey)
73−
74−newtype OperationTree = OperationTree
75− { parameters :: Map ParamKey (Errorable ParamTree)
76− }
77− deriving stock (Show, Generic)
78− deriving newtype (Eq, Ord, Semigroup, Monoid, FromJSON, ToJSON)
79−
80−instance Nested OperationTree where
81− type Parent OperationTree = PathItemTree
82− type Key OperationTree = OperationName
83− nest key p = PathItemTree (M.singleton key p) mempty
84−
85−data ServerTree = ServerTree
86− deriving stock (Eq, Ord, Show, Generic)
87− deriving (ToJSON, FromJSON) via Snake ServerTree
88−
89−data ParamTree = ParamTree
90− deriving stock (Eq, Ord, Show, Generic)
91− deriving (ToJSON, FromJSON) via Snake ParamTree
92−
93−instance Semigroup ParamTree where
94− (<>) = error "Not implemented"
95−instance Monoid ParamTree where
96− mappend = (<>)
97− mempty = error "Not implemented"
98−
99−instance Nested ParamTree where
100− type Key ParamTree = ParamKey
101− type Parent ParamTree = OperationTree
102− nest key p = OperationTree $ M.singleton key p
103−
104−deriving instance Ord ParamLocation
105−
106−data ParamKey = ParamKey
107− { name :: Text
108− , paramIn :: ParamLocation
109− }
110− deriving stock (Eq, Ord, Show, Generic)
111− deriving (FromJSON, ToJSON) via Snake ParamKey
112− deriving anyclass (ToJSONKey, FromJSONKey)
113−
114−getParamKey :: Param -> ParamKey
115−getParamKey p = ParamKey
116− { name = _paramName p
117− , paramIn = _paramIn p
118− }
src/OpenAPI/Checker/Run.hs+9−4
@@ -1,9 +1,14 @@
1module OpenAPI.Checker.Run (runChecker) where
1module OpenAPI.Checker.Run (runChecker) where
2
2
3+import Control.Category
3import Data.Aeson
4import Data.Aeson
5+import qualified Data.ByteString.Char8 as BSC
6+import Data.HList
7+import qualified Data.Yaml as Yaml
4import OpenAPI.Checker.Options
8import OpenAPI.Checker.Options
5−import OpenAPI.Checker.Report
9+import OpenAPI.Checker.Subtree
6−import OpenAPI.Checker.Validate
10+import OpenAPI.Checker.Validate.OpenApi ()
11+import Prelude hiding (id, (.))
7
12
8runChecker :: IO ()
13runChecker :: IO ()
9runChecker = do
14runChecker = do
@@ -16,5 +21,5 @@ runChecker = do
16 Right s -> pure s
21 Right s -> pure s
17 a <- parseSchema (clientFile opts)
22 a <- parseSchema (clientFile opts)
18 b <- parseSchema (serverFile opts)
23 b <- parseSchema (serverFile opts)
19− let report = reportCompat a b
24+ let report = runCompatFormula (pure id) $ checkCompatibility HNil (ProdCons a b)
20− printReport report
25+ BSC.putStrLn $ Yaml.encode report
src/OpenAPI/Checker/Subtree.hs+50−5
@@ -4,6 +4,7 @@ module OpenAPI.Checker.Subtree
4 , CompatM (..)
4 , CompatM (..)
5 , CompatFormula
5 , CompatFormula
6 , ProdCons (..)
6 , ProdCons (..)
7+ , HasUnsupportedFeature (..)
7 , runCompatFormula
8 , runCompatFormula
8 , localM
9 , localM
9 , localTrace
10 , localTrace
@@ -18,9 +19,11 @@ where
18import Control.Monad.Identity
19import Control.Monad.Identity
19import Control.Monad.Reader
20import Control.Monad.Reader
20import Control.Monad.State
21import Control.Monad.State
22+import Data.Aeson
21import Data.Functor.Compose
23import Data.Functor.Compose
22import Data.HList
24import Data.HList
23import Data.Kind
25import Data.Kind
26+import Data.Monoid
24import Data.OpenApi
27import Data.OpenApi
25import Data.Text
28import Data.Text
26import Data.Typeable
29import Data.Typeable
@@ -60,17 +63,59 @@ newtype CompatM t a = CompatM
60 , MonadState (MemoState VarRef)
63 , MonadState (MemoState VarRef)
61 )
64 )
62
65
63−type CompatFormula t = Compose (CompatM t) (FormulaF CheckIssue OpenApi)
66+type CompatFormula t = Compose (CompatM t) (FormulaF SubtreeCheckIssue OpenApi)
64
67
65−class (Typeable t, Ord (CheckIssue t)) => Subtree (t :: Type) where
68+class (Typeable t, Ord (CheckIssue t), Show (CheckIssue t)) => Subtree (t :: Type) where
66 type CheckEnv t :: [Type]
69 type CheckEnv t :: [Type]
67 data CheckIssue t :: Type
70 data CheckIssue t :: Type
68
71
72+ issueIsUnsupported :: CheckIssue t -> Bool
73+ issueIsUnsupported = const False
74+
69 -- | If we ever followed a reference, reroute the path through "components"
75 -- | If we ever followed a reference, reroute the path through "components"
70 normalizeTrace :: Trace OpenApi t -> Trace OpenApi t
76 normalizeTrace :: Trace OpenApi t -> Trace OpenApi t
71
77
72 checkCompatibility :: HasAll (CheckEnv t) xs => HList xs -> ProdCons t -> CompatFormula t ()
78 checkCompatibility :: HasAll (CheckEnv t) xs => HList xs -> ProdCons t -> CompatFormula t ()
73
79
80+class HasUnsupportedFeature x where
81+ hasUnsupportedFeature :: x -> Bool
82+
83+instance HasUnsupportedFeature () where
84+ hasUnsupportedFeature () = False
85+
86+instance
87+ (HasUnsupportedFeature a, HasUnsupportedFeature b)
88+ => HasUnsupportedFeature (Either a b)
89+ where
90+ hasUnsupportedFeature (Left x) = hasUnsupportedFeature x
91+ hasUnsupportedFeature (Right x) = hasUnsupportedFeature x
92+
93+instance Subtree t => HasUnsupportedFeature (CheckIssue t) where
94+ hasUnsupportedFeature = issueIsUnsupported
95+
96+instance
97+ (forall x. HasUnsupportedFeature (f x))
98+ => HasUnsupportedFeature (T.TracePrefixTree f r)
99+ where
100+ hasUnsupportedFeature =
101+ getAny . T.foldWith (\_ fa -> Any $ hasUnsupportedFeature fa)
102+
103+data SubtreeCheckIssue t where
104+ SubtreeCheckIssue :: Subtree t => CheckIssue t -> SubtreeCheckIssue t
105+
106+deriving stock instance Eq (SubtreeCheckIssue t)
107+
108+deriving stock instance Ord (SubtreeCheckIssue t)
109+
110+instance Subtree t => ToJSON (CheckIssue t) where
111+ toJSON = toJSON . show
112+
113+instance HasUnsupportedFeature (SubtreeCheckIssue t) where
114+ hasUnsupportedFeature (SubtreeCheckIssue i) = hasUnsupportedFeature i
115+
116+instance ToJSON (SubtreeCheckIssue t) where
117+ toJSON (SubtreeCheckIssue i) = toJSON i
118+
74runCompatFormula
119runCompatFormula
75 :: ProdCons (Trace OpenApi t)
120 :: ProdCons (Trace OpenApi t)
76 -> Compose (CompatM t) (FormulaF f r) a
121 -> Compose (CompatM t) (FormulaF f r) a
@@ -93,7 +138,7 @@ localTrace xs (Compose h) = Compose (localM xs h)
93
138
94issueAtTrace
139issueAtTrace
95 :: Subtree t => Trace OpenApi t -> CheckIssue t -> CompatFormula t a
140 :: Subtree t => Trace OpenApi t -> CheckIssue t -> CompatFormula t a
96−issueAtTrace xs issue = Compose $ pure $ anError $ AnItem xs issue
141+issueAtTrace xs issue = Compose $ pure $ anError $ AnItem xs $ SubtreeCheckIssue issue
97
142
98issueAt
143issueAt
99 :: Subtree t
144 :: Subtree t
@@ -102,7 +147,7 @@ issueAt
102 -> CompatFormula t a
147 -> CompatFormula t a
103issueAt f issue = Compose $ do
148issueAt f issue = Compose $ do
104 xs <- asks f
149 xs <- asks f
105− pure $ anError $ AnItem xs issue
150+ pure $ anError $ AnItem xs $ SubtreeCheckIssue issue
106
151
107anyOfM
152anyOfM
108 :: Ord (f t)
153 :: Ord (f t)
@@ -121,7 +166,7 @@ anyOfAt
121 -> CompatFormula t a
166 -> CompatFormula t a
122anyOfAt f issue fs = Compose $ do
167anyOfAt f issue fs = Compose $ do
123 xs <- asks f
168 xs <- asks f
124− (`eitherOf` AnItem xs issue) <$> sequenceA (getCompose <$> fs)
169+ (`eitherOf` AnItem xs (SubtreeCheckIssue issue)) <$> sequenceA (getCompose <$> fs)
125
170
126fixpointKnot
171fixpointKnot
127 :: MonadState (MemoState VarRef) m
172 :: MonadState (MemoState VarRef) m
src/OpenAPI/Checker/Trace.hs+1−1
@@ -28,7 +28,7 @@ import Type.Reflection
28import Prelude hiding ((.))
28import Prelude hiding ((.))
29
29
30class
30class
31− (Typeable a, Typeable b, Ord (Step a b)) =>
31+ (Typeable a, Typeable b, Ord (Step a b), Show (Step a b)) =>
32 Steppable (a :: k) (b :: k)
32 Steppable (a :: k) (b :: k)
33 where
33 where
34 -- | How to get from an @a@ node to a @b@ node
34 -- | How to get from an @a@ node to a @b@ node
src/OpenAPI/Checker/TracePrefixTree.hs+92−35
@@ -1,4 +1,5 @@
1{-# LANGUAGE QuantifiedConstraints #-}
1{-# LANGUAGE QuantifiedConstraints #-}
2+
2module OpenAPI.Checker.TracePrefixTree
3module OpenAPI.Checker.TracePrefixTree
3 ( TracePrefixTree
4 ( TracePrefixTree
4 , empty
5 , empty
@@ -8,65 +9,87 @@ module OpenAPI.Checker.TracePrefixTree
8 , foldWith
9 , foldWith
9 , toList
10 , toList
10 , filter
11 , filter
12+ )
11− ) where
13+where
12
14
13−import qualified GHC.Exts as T
15+import Data.Aeson
14import Data.Foldable hiding (null, toList)
16import Data.Foldable hiding (null, toList)
17+import qualified Data.HashMap.Strict as HM
15import Data.Kind
18import Data.Kind
16import qualified Data.Map as M
19import qualified Data.Map as M
17import Data.Monoid
20import Data.Monoid
18import qualified Data.Set as S
21import qualified Data.Set as S
19−import qualified Data.TypeRepMap as T
22+import qualified Data.Text as T
23+import Data.Type.Equality
24+import qualified Data.TypeRepMap as TRM
25+import qualified Data.Vector as V
26+import qualified GHC.Exts as TRM
20import OpenAPI.Checker.Trace
27import OpenAPI.Checker.Trace
21−import Prelude hiding (null, filter)
22import Type.Reflection
28import Type.Reflection
23−import Data.Type.Equality
29+import Prelude hiding (filter, null)
24
30
25-- | A list of @AnItem r f@, but optimized into a prefix tree.
31-- | A list of @AnItem r f@, but optimized into a prefix tree.
26data TracePrefixTree (f :: k -> Type) (r :: k) = TracePrefixTree
32data TracePrefixTree (f :: k -> Type) (r :: k) = TracePrefixTree
27 { rootItems :: !(ASet (f r))
33 { rootItems :: !(ASet (f r))
28− , snocItems :: !(T.TypeRepMap (AStep f r))
34+ , snocItems :: !(TRM.TypeRepMap (AStep f r))
29 }
35 }
30
36
37+instance (forall a. ToJSON (f a)) => ToJSON (TracePrefixTree f r) where
38+ toJSON =
39+ Object . getMergableObject
40+ . foldWith (\t x -> MergableObject . traceObject t $ toJSON x)
41+
31deriving instance Eq (TracePrefixTree f a)
42deriving instance Eq (TracePrefixTree f a)
32
43
33-- Kind of orphan. Treat the map as an infinite tuple of @Maybe (f a)@'s, where
44-- Kind of orphan. Treat the map as an infinite tuple of @Maybe (f a)@'s, where
34-- the components are ordered by the @SomeTypeRep@ of the @a@.
45-- the components are ordered by the @SomeTypeRep@ of the @a@.
35compareTRM
46compareTRM
36 :: (forall a. Typeable a => Ord (f a))
47 :: (forall a. Typeable a => Ord (f a))
37− => T.TypeRepMap f -> T.TypeRepMap f -> Ordering
48+ => TRM.TypeRepMap f
49+ -> TRM.TypeRepMap f
50+ -> Ordering
38−compareTRM s1 s2
51+compareTRM s1 s2 =
39− = foldMap (\k -> compareMaybe compareW (M.lookup k m1) (M.lookup k m2)) mKeys
52+ foldMap (\k -> compareMaybe compareW (M.lookup k m1) (M.lookup k m2)) mKeys
40 where
53 where
41 (m1, m2) = (toMap s1, toMap s2)
54 (m1, m2) = (toMap s1, toMap s2)
42 mKeys = S.toAscList $ M.keysSet m1 `S.union` M.keysSet m2
55 mKeys = S.toAscList $ M.keysSet m1 `S.union` M.keysSet m2
43− compareMaybe _ Nothing Nothing = EQ
56+ compareMaybe _ Nothing Nothing = EQ
44− compareMaybe _ Nothing (Just _) = LT
57+ compareMaybe _ Nothing (Just _) = LT
45− compareMaybe _ (Just _) Nothing = GT
58+ compareMaybe _ (Just _) Nothing = GT
46 compareMaybe cmp (Just x) (Just y) = cmp x y
59 compareMaybe cmp (Just x) (Just y) = cmp x y
47 compareW
60 compareW
48 :: (forall a. Typeable a => Ord (f a))
61 :: (forall a. Typeable a => Ord (f a))
49− => T.WrapTypeable f -> T.WrapTypeable f -> Ordering
62+ => TRM.WrapTypeable f
63+ -> TRM.WrapTypeable f
64+ -> Ordering
50− compareW (T.WrapTypeable (x :: f a)) (T.WrapTypeable (y :: f b))
65+ compareW (TRM.WrapTypeable (x :: f a)) (TRM.WrapTypeable (y :: f b))
51 | Just Refl <- testEquality (typeRep @a) (typeRep @b) = compare x y
66 | Just Refl <- testEquality (typeRep @a) (typeRep @b) = compare x y
52 | otherwise = EQ -- unreachable
67 | otherwise = EQ -- unreachable
68+ toMap s =
53− toMap s = M.fromList
69+ M.fromList
54− [(someTypeRep x, w) | w@(T.WrapTypeable x) <- T.toList s]
70+ [(someTypeRep x, w) | w@(TRM.WrapTypeable x) <- TRM.toList s]
55
71
56instance Ord (TracePrefixTree f a) where
72instance Ord (TracePrefixTree f a) where
57− compare (TracePrefixTree r1 s1) (TracePrefixTree r2 s2)
73+ compare (TracePrefixTree r1 s1) (TracePrefixTree r2 s2) =
58− = compare r1 r2 <> compareTRM s1 s2
74+ compare r1 r2 <> compareTRM s1 s2
59
75
60data ASet (a :: Type) where
76data ASet (a :: Type) where
61 AnEmptySet :: ASet a
77 AnEmptySet :: ASet a
62 ASet :: Ord a => S.Set a -> ASet a
78 ASet :: Ord a => S.Set a -> ASet a
63
79
80+instance ToJSON a => ToJSON (ASet a) where
81+ toJSON =
82+ toJSON . \case
83+ AnEmptySet -> S.empty
84+ ASet s -> s
85+
64instance Semigroup (ASet a) where
86instance Semigroup (ASet a) where
65 AnEmptySet <> s = s
87 AnEmptySet <> s = s
66 s <> AnEmptySet = s
88 s <> AnEmptySet = s
67 ASet s1 <> ASet s2 = ASet $ S.union s1 s2
89 ASet s1 <> ASet s2 = ASet $ S.union s1 s2
68
90
69deriving instance Eq (ASet a)
91deriving instance Eq (ASet a)
92+
70deriving instance Ord (ASet a)
93deriving instance Ord (ASet a)
71
94
72-- type traceprefixset = traceprefixtree proxy
95-- type traceprefixset = traceprefixtree proxy
@@ -76,26 +99,33 @@ instance Monoid (ASet a) where
76
99
77data AStep (f :: k -> Type) (r :: k) (a :: k) where
100data AStep (f :: k -> Type) (r :: k) (a :: k) where
78 AStep
101 AStep
102+ :: Steppable r a =>
79− :: Steppable r a => !(M.Map (Step r a) (TracePrefixTree f a)) -> AStep f r a
103+ !(M.Map (Step r a) (TracePrefixTree f a))
104+ -> AStep f r a
80
105
81deriving instance Eq (AStep f r a)
106deriving instance Eq (AStep f r a)
107+
82deriving instance Ord (AStep f r a)
108deriving instance Ord (AStep f r a)
83
109
84singleton :: AnItem f r -> TracePrefixTree f r
110singleton :: AnItem f r -> TracePrefixTree f r
85−singleton (AnItem ys v) = go ys $ TracePrefixTree (ASet $ S.singleton v) T.empty
111+singleton (AnItem ys v) = go ys $ TracePrefixTree (ASet $ S.singleton v) TRM.empty
86 where
112 where
87 go :: Trace r a -> TracePrefixTree f a -> TracePrefixTree f r
113 go :: Trace r a -> TracePrefixTree f a -> TracePrefixTree f r
88 go Root !t = t
114 go Root !t = t
115+ go (Snoc xs x) !t =
116+ go xs $
89− go (Snoc xs x) !t = go xs $ TracePrefixTree AnEmptySet $ T.one
117+ TracePrefixTree AnEmptySet $
118+ TRM.one $
90− $ AStep $ M.singleton x t
119+ AStep $ M.singleton x t
91
120
92instance Semigroup (TracePrefixTree f r) where
121instance Semigroup (TracePrefixTree f r) where
93 TracePrefixTree r1 s1 <> TracePrefixTree r2 s2 =
122 TracePrefixTree r1 s1 <> TracePrefixTree r2 s2 =
94− TracePrefixTree (r1 <> r2) (T.unionWith joinSteps s1 s2)
123+ TracePrefixTree (r1 <> r2) (TRM.unionWith joinSteps s1 s2)
124+ where
95− where joinSteps (AStep m1) (AStep m2) = AStep $ M.unionWith (<>) m1 m2
125+ joinSteps (AStep m1) (AStep m2) = AStep $ M.unionWith (<>) m1 m2
96
126
97instance Monoid (TracePrefixTree f r) where
127instance Monoid (TracePrefixTree f r) where
98− mempty = TracePrefixTree mempty T.empty
128+ mempty = TracePrefixTree mempty TRM.empty
99
129
100empty :: TracePrefixTree f r
130empty :: TracePrefixTree f r
101empty = mempty
131empty = mempty
@@ -104,12 +134,15 @@ fromList :: [AnItem f r] -> TracePrefixTree f r
104fromList = foldMap singleton
134fromList = foldMap singleton
105
135
106null :: TracePrefixTree f r -> Bool
136null :: TracePrefixTree f r -> Bool
107−null (TracePrefixTree AnEmptySet s) = T.size s == 0
137+null (TracePrefixTree AnEmptySet s) = TRM.size s == 0
108null _ = False
138null _ = False
109
139
110foldWith
140foldWith
111− :: forall f m r. Monoid m
141+ :: forall f m r.
142+ Monoid m
112− => (forall a. Ord (f a) => Trace r a -> f a -> m) -> TracePrefixTree f r -> m
143+ => (forall a. Ord (f a) => Trace r a -> f a -> m)
144+ -> TracePrefixTree f r
145+ -> m
113foldWith k = goTPT Root
146foldWith k = goTPT Root
114 where
147 where
115 goTPT :: forall a. Trace r a -> TracePrefixTree f a -> m
148 goTPT :: forall a. Trace r a -> TracePrefixTree f a -> m
@@ -117,17 +150,41 @@ foldWith k = goTPT Root
117 goASet :: forall a. Trace r a -> ASet (f a) -> m
150 goASet :: forall a. Trace r a -> ASet (f a) -> m
118 goASet _ AnEmptySet = mempty
151 goASet _ AnEmptySet = mempty
119 goASet xs (ASet rs) = foldMap (k xs) rs
152 goASet xs (ASet rs) = foldMap (k xs) rs
120− goTRM :: forall a. Trace r a -> T.TypeRepMap (AStep f a) -> m
153+ goTRM :: forall a. Trace r a -> TRM.TypeRepMap (AStep f a) -> m
121− goTRM xs s = foldMap (\(T.WrapTypeable f) -> goAStep xs f) $ T.toList s
154+ goTRM xs s = foldMap (\(TRM.WrapTypeable f) -> goAStep xs f) $ TRM.toList s
122 goAStep :: forall a b. Trace r a -> AStep f a b -> m
155 goAStep :: forall a b. Trace r a -> AStep f a b -> m
123− goAStep xs (AStep m)
156+ goAStep xs (AStep m) =
124− = M.foldrWithKey (\x t -> (goTPT (Snoc xs x) t <>)) mempty m
157+ M.foldrWithKey (\x t -> (goTPT (Snoc xs x) t <>)) mempty m
125
158
126toList :: TracePrefixTree f r -> [AnItem f r]
159toList :: TracePrefixTree f r -> [AnItem f r]
127−toList t = appEndo (foldWith (\xs f -> Endo (AnItem xs f:)) t) []
160+toList t = appEndo (foldWith (\xs f -> Endo (AnItem xs f :)) t) []
128
161
129-- | Select a subtree by prefix
162-- | Select a subtree by prefix
130filter :: Trace r a -> TracePrefixTree f r -> TracePrefixTree f a
163filter :: Trace r a -> TracePrefixTree f r -> TracePrefixTree f a
131filter Root t = t
164filter Root t = t
165+filter (Snoc xs x) t =
132−filter (Snoc xs x) t = foldMap (\(AStep m) -> fold $ M.lookup x m)
166+ foldMap (\(AStep m) -> fold $ M.lookup x m) $
133− $ T.lookup $ snocItems $ filter xs t
167+ TRM.lookup $ snocItems $ filter xs t
168+
169+newtype MergableObject = MergableObject {getMergableObject :: Object}
170+
171+instance Semigroup MergableObject where
172+ (MergableObject x) <> (MergableObject y) =
173+ MergableObject $ HM.unionWith mergeValue x y
174+ where
175+ mergeValue :: Value -> Value -> Value
176+ mergeValue (Object a) (Object b) =
177+ Object . getMergableObject $ MergableObject a <> MergableObject b
178+ mergeValue (Array a) (Array b) = Array $ a <> b
179+ mergeValue (Array a) b = Array $ V.snoc a b
180+ mergeValue a (Array b) = Array $ V.cons a b
181+ mergeValue a b = toJSON [a, b]
182+
183+instance Monoid MergableObject where
184+ mempty = MergableObject mempty
185+
186+traceObject :: Trace r a -> Value -> Object
187+traceObject Root (Object o) = o
188+traceObject Root v = HM.singleton "root" v
189+traceObject (root `Snoc` s) v =
190+ traceObject root . Object $ HM.singleton (T.pack . show $ s) v
src/OpenAPI/Checker/Validate.hsdeleted−96
@@ -1,96 +0,0 @@
1−module OpenAPI.Checker.Validate where
2−
3−import Control.Monad
4−import Control.Monad.Reader
5−import Data.Functor
6−import Data.HashMap.Strict.InsOrd as InsMap
7−import Data.HashSet.InsOrd as InsSet
8−import Data.Map.Strict as M
9−import Data.OpenApi
10−import Data.OpenApi.Internal
11−import Data.Traversable
12−import OpenAPI.Checker.Aux
13−import OpenAPI.Checker.Report
14−import OpenAPI.Checker.Validate.Dereference
15−import OpenAPI.Checker.Validate.Monad
16−
17−reportCompat :: OpenApi -> OpenApi -> Report
18−reportCompat = error "FIXME: reportCompat not implemented"
19−
20−forwardCompatible :: OpenApi -> OpenApi -> Errorable ReportTree
21−forwardCompatible old new
22− = fmap snd
23− $ runTreeM emptyEnv
24− $ openApiCompatible old new
25−
26−openApiCompatible :: OpenApi -> OpenApi -> TreeM ReportTree ()
27−openApiCompatible old new = do
28− local (const servers) $ do
29− follow $ (InsMap.toList $ _openApiPaths old) <&> \(path, oldItem) ->
30− (path, checkItem path oldItem)
31− where
32− servers = Env
33− { oldServers = _openApiServers old
34− , newServers = _openApiServers new }
35− checkItem path oldItem = do
36− case (InsMap.lookup path $ _openApiPaths new) of
37− Nothing -> treeError $ "Path deleted"
38− Just newItem ->
39− pathItemsCompatible oldItem newItem
40−
41−
42−mergeEnvServers :: [Server] -> [Server] -> TreeM t Env
43−mergeEnvServers olds news = do
44− env <- ask
45− return $ Env
46− { oldServers = mergeServers (oldServers env) olds
47− , newServers = mergeServers (newServers env) news }
48−
49−pathItemsCompatible
50− :: PathItem
51− -> PathItem
52− -> TreeM PathItemTree ()
53−pathItemsCompatible old new = do
54− newEnv <- mergeEnvServers (_pathItemServers old) (_pathItemServers new)
55− local (const newEnv) $ do
56− follow
57− [ (Get, go _pathItemGet)
58− , (Put, go _pathItemPut)
59− , (Post, go _pathItemPost)
60− , (Delete, go _pathItemDelete)
61− , (Options, go _pathItemOptions)
62− , (Head, go _pathItemHead)
63− , (Patch, go _pathItemPatch)
64− , (Trace, go _pathItemTrace) ]
65− where
66− go :: (PathItem -> Maybe Operation) -> TreeM OperationTree ()
67− go getOp = case getOp old of
68− Nothing -> return ()
69− -- Operation is not in old schema, so any addition is Ok
70− Just oldOp -> case getOp new of
71− Nothing -> do
72− -- Operation was in old schema, but no in new one.
73− treeError "Operation was deleted. Old client may try to use it."
74− Just newOp ->
75− operationsCompatible oldOp newOp
76−
77−operationsCompatible
78− :: Operation
79− -> Operation
80− -> TreeM OperationTree ()
81−operationsCompatible old new = do
82− oldParams <- traverse dereferenceParam $ _operationParameters old
83− newParams <- traverse dereferenceParam $ _operationParameters new
84− let
85− newPMap = M.fromList $ newParams <&> \p -> (getParamKey p, p)
86− checkParam pkey oldP = case M.lookup pkey newPMap of
87− Nothing ->
88− treeError "Param was deleted in new interface, but exists in old"
89− Just newP -> do
90− paramsCompatible oldP newP
91− follow $ oldParams <&> \oldP ->
92− let pkey = getParamKey oldP
93− in (pkey , checkParam pkey oldP)
94−
95−paramsCompatible :: Param -> Param -> TreeM ParamTree ()
96−paramsCompatible = error "FIXME: paramsCompatible not implemented"
src/OpenAPI/Checker/Validate/Dereference.hsdeleted−8
@@ -1,8 +0,0 @@
1−module OpenAPI.Checker.Validate.Dereference where
2−
3−import Data.OpenApi.Internal
4−import OpenAPI.Checker.Validate.Monad
5−
6−-- | Throws error if param not found
7−dereferenceParam :: Referenced Param -> TreeM t Param
8−dereferenceParam = error "FIXME: dereferenceParam not implemented"
src/OpenAPI/Checker/Validate/Monad.hsdeleted−52
@@ -1,52 +0,0 @@
1−module OpenAPI.Checker.Validate.Monad where
2−
3−import Control.Lens
4−import Control.Monad.Except
5−import Control.Monad.Trans.Except
6−import Control.Monad.Trans.Reader
7−import Control.Monad.Trans.State.Strict
8−import Data.Foldable
9−import Data.Functor.Identity
10−import Data.OpenApi.Internal
11−import Data.Text (Text)
12−import Data.Traversable
13−import GHC.Generics (Generic)
14−
15−type TreeM t = ReaderT Env (StateT t Errorable)
16−
17−data Env = Env
18− { oldServers :: [Server]
19− , newServers :: [Server]
20− } deriving (Eq, Generic)
21−
22−emptyEnv :: Env
23−emptyEnv = Env [] []
24−
25−-- | Might be different type in future
26−type Errorable = Either Err
27−
28−type Err = Text
29−
30−-- | Class of trees nested into another trees
31−class (Monoid (Parent t)) => Nested t where
32− type Parent t
33− type Key t
34− nest :: Key t -> Errorable t -> Parent t
35−
36−runTreeM :: (Monoid t) => Env -> TreeM t a -> Errorable (a, t)
37−runTreeM env ma = runStateT (runReaderT ma env) mempty
38−
39−-- | Throws error in current tree
40−treeError :: Err -> TreeM t a
41−treeError = throwError
42−
43−-- | Runs several computations in different paths in subtrees
44−follow
45− :: (Foldable f, Nested t, Monoid t)
46− => f (Key t, TreeM t a)
47− -> TreeM (Parent t) ()
48−follow tree = do
49− env <- ask
50− for_ tree $ \(key, sub) -> do
51− let p = nest key $ fmap snd $ runTreeM env sub
52− id <>= p
src/OpenAPI/Checker/Validate/OpenApi.hs+6−6
@@ -20,7 +20,7 @@ import OpenAPI.Checker.Validate.PathFragment
20instance Subtree OpenApi where
20instance Subtree OpenApi where
21 type CheckEnv OpenApi = '[]
21 type CheckEnv OpenApi = '[]
22 data CheckIssue OpenApi = NoPathsMatched | WrongNumberOfFragments
22 data CheckIssue OpenApi = NoPathsMatched | WrongNumberOfFragments
23− deriving (Eq, Ord)
23+ deriving (Eq, Ord, Show)
24 normalizeTrace = undefined
24 normalizeTrace = undefined
25 checkCompatibility _ prodCons = do
25 checkCompatibility _ prodCons = do
26 let ProdCons {producer = p, consumer = c} = processOpenApi <$> prodCons
26 let ProdCons {producer = p, consumer = c} = processOpenApi <$> prodCons
@@ -106,25 +106,25 @@ processOpenApi o = do
106
106
107instance Steppable OpenApi PathItem where
107instance Steppable OpenApi PathItem where
108 data Step OpenApi PathItem = PathStep FilePath
108 data Step OpenApi PathItem = PathStep FilePath
109− deriving (Eq, Ord)
109+ deriving (Eq, Ord, Show)
110
110
111instance Steppable PathItem PathFragment where
111instance Steppable PathItem PathFragment where
112 data Step PathItem PathFragment
112 data Step PathItem PathFragment
113 = -- | The index of the path item
113 = -- | The index of the path item
114 PathFragmentStep Int
114 PathFragmentStep Int
115− deriving (Eq, Ord)
115+ deriving (Eq, Ord, Show)
116
116
117instance Steppable PathFragment PathItem where
117instance Steppable PathFragment PathItem where
118 data Step PathFragment PathItem = PathFragmentParentStep
118 data Step PathFragment PathItem = PathFragmentParentStep
119− deriving (Eq, Ord)
119+ deriving (Eq, Ord, Show)
120
120
121instance Steppable PathItem (Referenced Param) where
121instance Steppable PathItem (Referenced Param) where
122 data Step PathItem (Referenced Param) = PathItemParametersStep
122 data Step PathItem (Referenced Param) = PathItemParametersStep
123− deriving (Eq, Ord)
123+ deriving (Eq, Ord, Show)
124
124
125instance Steppable Operation (Referenced Param) where
125instance Steppable Operation (Referenced Param) where
126 data Step Operation (Referenced Param) = OperationParametersStep
126 data Step Operation (Referenced Param) = OperationParametersStep
127− deriving (Eq, Ord)
127+ deriving (Eq, Ord, Show)
128
128
129data ForeachOperation a = ForeachOperation
129data ForeachOperation a = ForeachOperation
130 { processedPathItemGet :: a
130 { processedPathItemGet :: a
src/OpenAPI/Checker/Validate/Operation.hs+2−2
@@ -9,7 +9,7 @@ import OpenAPI.Checker.Trace
9instance Subtree Operation where
9instance Subtree Operation where
10 type CheckEnv Operation = '[]
10 type CheckEnv Operation = '[]
11 data CheckIssue Operation
11 data CheckIssue Operation
12− deriving (Eq, Ord)
12+ deriving (Eq, Ord, Show)
13 normalizeTrace = undefined
13 normalizeTrace = undefined
14 checkCompatibility = undefined
14 checkCompatibility = undefined
15
15
@@ -23,4 +23,4 @@ instance Steppable PathItem Operation where
23 | HeadStep
23 | HeadStep
24 | PatchStep
24 | PatchStep
25 | TraceStep
25 | TraceStep
26− deriving (Eq, Ord)
26+ deriving (Eq, Ord, Show)
src/OpenAPI/Checker/Validate/Param.hs+1−1
@@ -8,6 +8,6 @@ import OpenAPI.Checker.Subtree
8instance Subtree Param where
8instance Subtree Param where
9 type CheckEnv Param = '[]
9 type CheckEnv Param = '[]
10 data CheckIssue Param
10 data CheckIssue Param
11− deriving (Eq, Ord)
11+ deriving (Eq, Ord, Show)
12 normalizeTrace = undefined
12 normalizeTrace = undefined
13 checkCompatibility = undefined
13 checkCompatibility = undefined
src/OpenAPI/Checker/Validate/PathFragment.hs+2−2
@@ -53,14 +53,14 @@ data PathFragment
53
53
54instance Steppable PathFragment Param where
54instance Steppable PathFragment Param where
55 data Step PathFragment Param = StaticPathParam
55 data Step PathFragment Param = StaticPathParam
56− deriving (Eq, Ord)
56+ deriving (Eq, Ord, Show)
57
57
58type PathParamRefs = TracedReferences PathFragment Param
58type PathParamRefs = TracedReferences PathFragment Param
59
59
60instance Subtree PathFragment where
60instance Subtree PathFragment where
61 type CheckEnv PathFragment = '[ProdCons PathParamRefs]
61 type CheckEnv PathFragment = '[ProdCons PathParamRefs]
62 data CheckIssue PathFragment = PathFragmentsDontMatch Text Text
62 data CheckIssue PathFragment = PathFragmentsDontMatch Text Text
63− deriving (Eq, Ord)
63+ deriving (Eq, Ord, Show)
64
64
65 normalizeTrace = undefined
65 normalizeTrace = undefined
66
66
test/Spec.hs+3−6
@@ -1,7 +1,6 @@
1module Main (main) where
1module Main (main) where
2
2
3−import qualified Spec.Golden.Report
3+import qualified Spec.Golden.TraceTree
4−import qualified Spec.Golden.ReportTree
5import Test.Tasty
4import Test.Tasty
6
5
7main :: IO ()
6main :: IO ()
@@ -9,11 +8,9 @@ main = defaultMain =<< tests
9
8
10tests :: IO TestTree
9tests :: IO TestTree
11tests = do
10tests = do
12− goldenReport <- Spec.Golden.Report.tests
13− goldenReportTree <- Spec.Golden.ReportTree.tests
11+ goldenReportTree <- Spec.Golden.TraceTree.tests
14 return $
12 return $
15 testGroup
13 testGroup
16 "Golden tests"
14 "Golden tests"
17− [ goldenReport,
18− goldenReportTree
15+ [ goldenReportTree
19 ]
16 ]
test/Spec/Golden/Extra.hs+46−50
@@ -1,8 +1,8 @@
1module Spec.Golden.Extra
1module Spec.Golden.Extra
2− ( getGoldenInputs,
2+ ( getGoldenInputs
3− getGoldenInputsUniform,
3+ , getGoldenInputsUniform
4− goldenInputsTree,
4+ , goldenInputsTree
5− goldenInputsTreeUniform,
5+ , goldenInputsTreeUniform
6 )
6 )
7where
7where
8
8
@@ -11,7 +11,7 @@ import Control.Monad
11import Data.Aeson hiding (Result)
11import Data.Aeson hiding (Result)
12import qualified Data.ByteString.Lazy as BSL
12import qualified Data.ByteString.Lazy as BSL
13import qualified Data.Yaml as Yaml
13import qualified Data.Yaml as Yaml
14−import OpenAPI.Checker.Report
14+import OpenAPI.Checker.Subtree
15import System.Directory
15import System.Directory
16import System.FilePath
16import System.FilePath
17import Test.Tasty
17import Test.Tasty
@@ -23,12 +23,12 @@ data TestInput t
23 | TestInputLeaf TestName t FilePath
23 | TestInputLeaf TestName t FilePath
24 deriving (Functor)
24 deriving (Functor)
25
25
26−getGoldenInputs ::
26+getGoldenInputs
27− (Each s t (FilePath, FilePath -> IO a) a) =>
27+ :: (Each s t (FilePath, FilePath -> IO a) a)
28− TestName ->
28+ => TestName
29− FilePath ->
29+ -> FilePath
30− s ->
30+ -> s
31− IO (TestInput t)
31+ -> IO (TestInput t)
32getGoldenInputs name filepath inp = do
32getGoldenInputs name filepath inp = do
33 dirs' <- listDirectory filepath >>= filterM (doesDirectoryExist . (filepath </>))
33 dirs' <- listDirectory filepath >>= filterM (doesDirectoryExist . (filepath </>))
34 case dirs' of
34 case dirs' of
@@ -43,35 +43,33 @@ getGoldenInputs name filepath inp = do
43 TestInputNode name
43 TestInputNode name
44 <$> forM dirs (\dir -> getGoldenInputs dir (filepath </> dir) inp)
44 <$> forM dirs (\dir -> getGoldenInputs dir (filepath </> dir) inp)
45
45
46−getGoldenInputsUniform ::
46+getGoldenInputsUniform
47− (Each t h (FilePath, FilePath -> IO a) a) =>
47+ :: (Each t h (FilePath, FilePath -> IO a) a)
48− (Each s t FilePath (FilePath, FilePath -> IO a)) =>
48+ => (Each s t FilePath (FilePath, FilePath -> IO a))
49− TestName ->
49+ => TestName
50− (FilePath -> IO a) ->
50+ -> (FilePath -> IO a)
51− FilePath ->
51+ -> FilePath
52− s ->
52+ -> s
53− IO (TestInput h)
53+ -> IO (TestInput h)
54getGoldenInputsUniform name f filepath inp = getGoldenInputs name filepath $ inp & each %~ (,f)
54getGoldenInputsUniform name f filepath inp = getGoldenInputs name filepath $ inp & each %~ (,f)
55
55
56−goldenInputsTree ::
56+goldenInputsTree
57− (Each s t (FilePath, FilePath -> IO a) a, ToJSON x, HasUnsupportedFeature x) =>
57+ :: (Each s t (FilePath, FilePath -> IO a) a, ToJSON x, HasUnsupportedFeature x)
58− TestName ->
58+ => TestName
59− -- | Root path
59+ -> FilePath -- ^ Root path
60− FilePath ->
61− -- | Name of golden file
60+ -> FilePath -- ^ Name of golden file
62− FilePath ->
61+ -> s
63− s ->
64− (t -> x) ->
62+ -> (t -> x)
65− IO TestTree
63+ -> IO TestTree
66goldenInputsTree name filepath golden inp f = do
64goldenInputsTree name filepath golden inp f = do
67 runTestInputTree golden f <$> getGoldenInputs name filepath inp
65 runTestInputTree golden f <$> getGoldenInputs name filepath inp
68
66
69−runTestInputTree ::
67+runTestInputTree
70− (ToJSON x, HasUnsupportedFeature x) =>
68+ :: (ToJSON x, HasUnsupportedFeature x)
71− FilePath ->
69+ => FilePath
72− (t -> x) ->
70+ -> (t -> x)
73− TestInput t ->
71+ -> TestInput t
74− TestTree
72+ -> TestTree
75runTestInputTree golden f (TestInputNode name rest) =
73runTestInputTree golden f (TestInputNode name rest) =
76 testGroup name (runTestInputTree golden f <$> rest)
74 testGroup name (runTestInputTree golden f <$> rest)
77runTestInputTree golden f (TestInputLeaf name t path)
75runTestInputTree golden f (TestInputLeaf name t path)
@@ -100,20 +98,18 @@ testSupported :: TestName -> Bool
100testSupported ('x' : ' ' : _) = False
98testSupported ('x' : ' ' : _) = False
101testSupported _ = True
99testSupported _ = True
102
100
103−goldenInputsTreeUniform ::
101+goldenInputsTreeUniform
104− ( Each t h (FilePath, FilePath -> IO a) a,
102+ :: ( Each t h (FilePath, FilePath -> IO a) a
105− ToJSON x,
103+ , ToJSON x
106− Each s t FilePath (FilePath, FilePath -> IO a),
104+ , Each s t FilePath (FilePath, FilePath -> IO a)
107− HasUnsupportedFeature x
105+ , HasUnsupportedFeature x
108− ) =>
106+ )
109− String ->
107+ => String
110− -- | Root path
108+ -> FilePath -- ^ Root path
111− FilePath ->
112− -- | Name of golden file
109+ -> FilePath -- ^ Name of golden file
113− FilePath ->
110+ -> s
114− s ->
115− (FilePath -> IO a) ->
111+ -> (FilePath -> IO a)
116− (h -> x) ->
112+ -> (h -> x)
117− IO TestTree
113+ -> IO TestTree
118goldenInputsTreeUniform name filepath golden inp h =
114goldenInputsTreeUniform name filepath golden inp h =
119 goldenInputsTree name filepath golden (inp & each %~ (,h))
115 goldenInputsTree name filepath golden (inp & each %~ (,h))
test/Spec/Golden/Report.hsdeleted−19
@@ -1,19 +0,0 @@
1−module Spec.Golden.Report
2− ( tests,
3− )
4−where
5−
6−import qualified Data.Yaml as Yaml
7−import OpenAPI.Checker.Validate
8−import Spec.Golden.Extra
9−import Test.Tasty
10−
11−tests :: IO TestTree
12−tests =
13− goldenInputsTreeUniform
14− "Golden Reports"
15− "test/golden/common"
16− "report.yaml"
17− ("a.yaml", "b.yaml")
18− Yaml.decodeFileThrow
19− (uncurry reportCompat)
test/Spec/Golden/ReportTree.hsdeleted−19
@@ -1,19 +0,0 @@
1−module Spec.Golden.ReportTree
2− ( tests,
3− )
4−where
5−
6−import qualified Data.Yaml as Yaml
7−import OpenAPI.Checker.Validate
8−import Spec.Golden.Extra
9−import Test.Tasty
10−
11−tests :: IO TestTree
12−tests =
13− goldenInputsTreeUniform
14− "Golden ReportTrees"
15− "test/golden/common"
16− "report-tree.yaml"
17− ("a.yaml", "b.yaml")
18− Yaml.decodeFileThrow
19− (uncurry forwardCompatible)
test/Spec/Golden/TraceTree.hsnew file+23
@@ -0,0 +1,23 @@
1+module Spec.Golden.TraceTree
2+ ( tests
3+ )
4+where
5+
6+import Control.Category
7+import Data.HList
8+import qualified Data.Yaml as Yaml
9+import OpenAPI.Checker.Subtree
10+import OpenAPI.Checker.Validate.OpenApi ()
11+import Spec.Golden.Extra
12+import Test.Tasty (TestTree)
13+import Prelude hiding (id, (.))
14+
15+tests :: IO TestTree
16+tests =
17+ goldenInputsTreeUniform
18+ "Golden TraceTree"
19+ "test/golden/common"
20+ "trace-tree.yaml"
21+ ("a.yaml", "b.yaml")
22+ Yaml.decodeFileThrow
23+ (runCompatFormula (pure id) . checkCompatibility HNil . uncurry ProdCons)