git.iko.soy/compaREST
on master help sign in
Removed Env from Reader (#21)
f53aae3iko
openapi-diff.cabal+1
compare with master
unifiedsplit
@@ -97,6 +97,7 @@ library
97 , OpenAPI.Checker.Validate.Dereference
97 , OpenAPI.Checker.Validate.Dereference
98 , OpenAPI.Checker.Validate.Monad
98 , OpenAPI.Checker.Validate.Monad
99 , OpenAPI.Checker.Options
99 , OpenAPI.Checker.Options
100+ , Data.HList
100
101
101executable openapi-diff
102executable openapi-diff
102 import: common-options
103 import: common-options
src/Data/HList.hsnew file+39
@@ -0,0 +1,39 @@
1+module Data.HList
2+ ( Has,
3+ HasAll,
4+ getH,
5+ HList (..),
6+ )
7+where
8+
9+import Data.Kind
10+import GHC.TypeLits
11+
12+data HList (xs :: [Type]) where
13+ HNil :: HList '[]
14+ HCons :: x -> HList xs -> HList (x ': xs)
15+
16+type family HasAll xs ys :: Constraint where
17+ HasAll '[] _ = ()
18+ HasAll (x ': xs) ys = (Has x ys, HasAll xs ys)
19+
20+type Has x xs = Has' x xs (HeadEq x xs)
21+
22+type family HeadEq x xs where
23+ HeadEq x (x ': _) = 'True
24+ HeadEq _ _ = 'False
25+
26+class t ~ HeadEq x xs => Has' (x :: Type) (xs :: [Type]) (t :: Bool) where
27+ getH :: HList xs -> x
28+
29+instance Has' x (x ': xs) 'True where
30+ getH (HCons x _) = x
31+
32+instance (Has' x xs t, HeadEq x (y : xs) ~ 'False) => Has' x (y ': xs) 'False where
33+ getH (HCons _ xs) = getH xs
34+
35+instance
36+ TypeError ( 'ShowType x ':<>: 'Text " is not a part of the list.") =>
37+ Has' x '[] 'False
38+ where
39+ getH HNil = undefined
src/OpenAPI/Checker/Subtree.hs+11−19
@@ -16,6 +16,7 @@ import Control.Monad.Identity
16import Control.Monad.Reader
16import Control.Monad.Reader
17import Control.Monad.State
17import Control.Monad.State
18import Data.Functor.Compose
18import Data.Functor.Compose
19+import Data.HList
19import Data.Kind
20import Data.Kind
20import Data.OpenApi
21import Data.OpenApi
21import Data.Text
22import Data.Text
@@ -38,32 +39,27 @@ instance Applicative ProdCons where
38 pure x = ProdCons x x
39 pure x = ProdCons x x
39 ProdCons fp fc <*> ProdCons xp xc = ProdCons (fp xp) (fc xc)
40 ProdCons fp fc <*> ProdCons xp xc = ProdCons (fp xp) (fc xc)
40
41
41−data TracedEnv t = TracedEnv
42− { getTrace :: Trace OpenApi t
43− , getEnv :: CheckEnv t
44− }
45−
46newtype CompatM t a = CompatM
42newtype CompatM t a = CompatM
47 { unCompatM ::
43 { unCompatM ::
48− ReaderT (ProdCons (TracedEnv t))
44+ ReaderT (ProdCons (Trace OpenApi t))
49 (StateT (MemoState VarRef) Identity) a
45 (StateT (MemoState VarRef) Identity) a
50 } deriving newtype
46 } deriving newtype
51 ( Functor, Applicative, Monad
47 ( Functor, Applicative, Monad
52− , MonadReader (ProdCons (TracedEnv t))
48+ , MonadReader (ProdCons (Trace OpenApi t))
53 , MonadState (MemoState VarRef)
49 , MonadState (MemoState VarRef)
54 )
50 )
55
51
56type CompatFormula t = Compose (CompatM t) (FormulaF CheckIssue OpenApi)
52type CompatFormula t = Compose (CompatM t) (FormulaF CheckIssue OpenApi)
57
53
58class (Typeable t, Ord t, Ord (CheckIssue t)) => Subtree (t :: Type) where
54class (Typeable t, Ord t, Ord (CheckIssue t)) => Subtree (t :: Type) where
59− type family CheckEnv t :: Type
55+ type family CheckEnv t :: [Type]
60 data family CheckIssue t :: Type
56 data family CheckIssue t :: Type
61 -- | If we ever followed a reference, reroute the path through "components"
57 -- | If we ever followed a reference, reroute the path through "components"
62 normalizeTrace :: Trace OpenApi t -> Trace OpenApi t
58 normalizeTrace :: Trace OpenApi t -> Trace OpenApi t
63− checkCompatibility :: ProdCons t -> CompatFormula t ()
59+ checkCompatibility :: HasAll (CheckEnv t) xs => HList xs -> ProdCons t -> CompatFormula t ()
64
60
65runCompatFormula
61runCompatFormula
66− :: ProdCons (TracedEnv t)
62+ :: ProdCons (Trace OpenApi t)
67 -> Compose (CompatM t) (FormulaF f r) a
63 -> Compose (CompatM t) (FormulaF f r) a
68 -> Either (T.TracePrefixTree f r) a
64 -> Either (T.TracePrefixTree f r) a
69runCompatFormula env (Compose f)
65runCompatFormula env (Compose f)
@@ -71,20 +67,16 @@ runCompatFormula env (Compose f)
71
67
72localM
68localM
73 :: ProdCons (Trace a b)
69 :: ProdCons (Trace a b)
74− -> (ProdCons (CheckEnv a) -> ProdCons (CheckEnv b))
75 -> CompatM b x
70 -> CompatM b x
76 -> CompatM a x
71 -> CompatM a x
77−localM xs wrapEnv (CompatM k) = CompatM $ ReaderT $ \env ->
72+localM xs (CompatM k) =
78− runReaderT k $ TracedEnv
79− <$> (catTrace <$> (getTrace <$> env) <*> xs)
73+ CompatM $ ReaderT $ \env -> runReaderT k (catTrace <$> env <*> xs)
80− <*> wrapEnv (getEnv <$> env)
81
74
82local'
75local'
83 :: ProdCons (Trace a b)
76 :: ProdCons (Trace a b)
84− -> (ProdCons (CheckEnv a) -> ProdCons (CheckEnv b))
85 -> Compose (CompatM b) (FormulaF f r) x
77 -> Compose (CompatM b) (FormulaF f r) x
86 -> Compose (CompatM a) (FormulaF f r) x
78 -> Compose (CompatM a) (FormulaF f r) x
87−local' xs wrapEnv (Compose h) = Compose (localM xs wrapEnv h)
79+local' xs (Compose h) = Compose (localM xs h)
88
80
89issueAtTrace
81issueAtTrace
90 :: Subtree t => Trace OpenApi t -> CheckIssue t -> CompatFormula t a
82 :: Subtree t => Trace OpenApi t -> CheckIssue t -> CompatFormula t a
@@ -96,7 +88,7 @@ issueAt
96 -> CheckIssue t
88 -> CheckIssue t
97 -> CompatFormula t a
89 -> CompatFormula t a
98issueAt f issue = Compose $ do
90issueAt f issue = Compose $ do
99− xs <- asks $ getTrace . f
91+ xs <- asks f
100 pure $ anError $ AnItem xs issue
92 pure $ anError $ AnItem xs issue
101
93
102anyOfM
94anyOfM
@@ -118,5 +110,5 @@ fixpointKnot = KnotTier
118
110
119memo :: Subtree t => CompatFormula t () -> CompatFormula t ()
111memo :: Subtree t => CompatFormula t () -> CompatFormula t ()
120memo (Compose f) = Compose $ do
112memo (Compose f) = Compose $ do
121− pxs <- asks (normalizeTrace . getTrace <$>)
113+ pxs <- asks (fmap normalizeTrace)
122 memoWithKnot fixpointKnot f pxs
114 memoWithKnot fixpointKnot f pxs