git.iko.soy/compaREST
on master help sign in
Removed Env from Reader (#21)

* Removed CheckEnv t from reader * Added HList Co-authored-by: mniip <mniip@users.noreply.github.com>

commitf53aae3bfb316dc8a2c5630554b784dc621dc7d5 authoriko <ilyakooo0@gmail.com> dateFri 12 Mar 2021, 19:25 (6 years ago) parent7261998
3 files changed+51−19
compare with master
unifiedsplit
openapi-diff.cabal+1 src/Data/HList.hs+39 src/OpenAPI/Checker/Subtree.hs+11−19
openapi-diff.cabal+1
@@ -97,6 +97,7 @@ library
9797 , OpenAPI.Checker.Validate.Dereference
9898 , OpenAPI.Checker.Validate.Monad
9999 , OpenAPI.Checker.Options
100+ , Data.HList
100101
101102executable openapi-diff
102103 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
1616import Control.Monad.Reader
1717import Control.Monad.State
1818import Data.Functor.Compose
19+import Data.HList
1920import Data.Kind
2021import Data.OpenApi
2122import Data.Text
@@ -38,32 +39,27 @@ instance Applicative ProdCons where
3839 pure x = ProdCons x x
3940 ProdCons fp fc <*> ProdCons xp xc = ProdCons (fp xp) (fc xc)
4041
41−data TracedEnv t = TracedEnv
42− { getTrace :: Trace OpenApi t
43− , getEnv :: CheckEnv t
44− }
45−
4642newtype CompatM t a = CompatM
4743 { unCompatM ::
48− ReaderT (ProdCons (TracedEnv t))
44+ ReaderT (ProdCons (Trace OpenApi t))
4945 (StateT (MemoState VarRef) Identity) a
5046 } deriving newtype
5147 ( Functor, Applicative, Monad
52− , MonadReader (ProdCons (TracedEnv t))
48+ , MonadReader (ProdCons (Trace OpenApi t))
5349 , MonadState (MemoState VarRef)
5450 )
5551
5652type CompatFormula t = Compose (CompatM t) (FormulaF CheckIssue OpenApi)
5753
5854class (Typeable t, Ord t, Ord (CheckIssue t)) => Subtree (t :: Type) where
59− type family CheckEnv t :: Type
55+ type family CheckEnv t :: [Type]
6056 data family CheckIssue t :: Type
6157 -- | If we ever followed a reference, reroute the path through "components"
6258 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 ()
6460
6561runCompatFormula
66− :: ProdCons (TracedEnv t)
62+ :: ProdCons (Trace OpenApi t)
6763 -> Compose (CompatM t) (FormulaF f r) a
6864 -> Either (T.TracePrefixTree f r) a
6965runCompatFormula env (Compose f)
@@ -71,20 +67,16 @@ runCompatFormula env (Compose f)
7167
7268localM
7369 :: ProdCons (Trace a b)
74− -> (ProdCons (CheckEnv a) -> ProdCons (CheckEnv b))
7570 -> CompatM b x
7671 -> CompatM a x
77−localM xs wrapEnv (CompatM k) = CompatM $ ReaderT $ \env ->
78− runReaderT k $ TracedEnv
79− <$> (catTrace <$> (getTrace <$> env) <*> xs)
80− <*> wrapEnv (getEnv <$> env)
72+localM xs (CompatM k) =
73+ CompatM $ ReaderT $ \env -> runReaderT k (catTrace <$> env <*> xs)
8174
8275local'
8376 :: ProdCons (Trace a b)
84− -> (ProdCons (CheckEnv a) -> ProdCons (CheckEnv b))
8577 -> Compose (CompatM b) (FormulaF f r) x
8678 -> 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)
8880
8981issueAtTrace
9082 :: Subtree t => Trace OpenApi t -> CheckIssue t -> CompatFormula t a
@@ -96,7 +88,7 @@ issueAt
9688 -> CheckIssue t
9789 -> CompatFormula t a
9890issueAt f issue = Compose $ do
99− xs <- asks $ getTrace . f
91+ xs <- asks f
10092 pure $ anError $ AnItem xs issue
10193
10294anyOfM
@@ -118,5 +110,5 @@ fixpointKnot = KnotTier
118110
119111memo :: Subtree t => CompatFormula t () -> CompatFormula t ()
120112memo (Compose f) = Compose $ do
121− pxs <- asks (normalizeTrace . getTrace <$>)
113+ pxs <- asks (fmap normalizeTrace)
122114 memoWithKnot fixpointKnot f pxs