src/OpenAPI/Checker/Subtree.hs · compaREST

git.iko.soy/compaREST

on dcd32cb help sign in

compaREST/src/OpenAPI/Checker/Subtree.hs

357 lines 10 kB history raw

1{-# OPTIONS_GHC -Wno-orphans #-}

3module OpenAPI.Checker.Subtree

4 ( Steppable (..)

5 , Step (..)

6 , TraceRoot

7 , Trace

8 , Traced

9 , Traced'

10 , pattern Traced

11 , traced

12 , retraced

13 , stepTraced

14 , Subtree (..)

15 , checkCompatibility

16 , checkSubstructure

17 , CompatM (..)

18 , CompatFormula'

19 , SemanticCompatFormula

20 , ProdCons (..)

21 , swapProdCons

22 , runCompatFormula

23 , issueAt

24 , anItem

25 , anIssue

26 , invertIssueOrientation

27 , invertIssueOrientationP

28 , embedFormula

29 , anyOfAt

30 , clarifyIssue

31 , structuralIssue

33 -- * Structural helpers

34 , structuralMaybe

35 , structuralMaybeWith

36 , structuralEq

37 , iohmStructural

38 , iohmStructuralWith

39 , structuralList

41 -- * Reexports

42 , (>>>)

43 , (<<<)

44 , extract

45 , ask

46 , local

47 , step

48 , Typeable

49 )

50where

52import Control.Comonad.Env

53import Control.Monad.Identity

54import Control.Monad.State

55import Data.Foldable

56import Data.Functor.Compose

57import Data.HList

58import qualified Data.HashMap.Strict.InsOrd as IOHM

59import Data.Hashable

60import Data.Kind

61import Data.OpenApi

62import qualified Data.Set as S

63import Data.Typeable

64import OpenAPI.Checker.Behavior

65import OpenAPI.Checker.Formula

66import OpenAPI.Checker.Memo

67import OpenAPI.Checker.Paths

68import qualified OpenAPI.Checker.PathsPrefixTree as P

70class

71 (Typeable Step, Typeable a, Typeable b, Ord (Step a b), Show (Step a b)) =>

72 Steppable (a :: Type) (b :: Type)

73 where

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

75 data Step a b :: Type

77data TraceRoot

79instance Steppable TraceRoot OpenApi where

80 data Step TraceRoot OpenApi

81 = ClientSchema

82 | ServerSchema

83 deriving stock (Eq, Ord, Show)

85type Trace = Paths Step TraceRoot

87type instance AdditionalQuiverConstraints Step _ _ = ()

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

91type Traced a = Traced' a a

93pattern Traced :: Trace a -> b -> Traced' a b

94pattern Traced t x = EnvT t (Identity x)

96{-# COMPLETE Traced #-}

98traced :: Trace a -> a -> Traced a

99traced = env

100

101retraced :: (Trace a -> Trace a') -> Traced' a b -> Traced' a' b

102retraced f (Traced a b) = Traced (f a) b

103

104stepTraced :: Steppable a a' => Step a a' -> Traced' a b -> Traced' a' b

105stepTraced s = retraced (>>> step s)

106

107data ProdCons a = ProdCons

108 { producer :: a

109 , consumer :: a

110 }

111 deriving stock (Eq, Ord, Show, Functor, Foldable, Traversable)

112

113swapProdCons

114 :: SwapEnvRoles xs

115 => (HList xs -> ProdCons x -> CompatFormula' q AnIssue r a)

116 -> (HList xs -> ProdCons x -> CompatFormula' q AnIssue r a)

117swapProdCons f e (ProdCons p c) =

118 invertIssueOrientation $

119 f (swapEnvRoles e) (ProdCons c p)

120{-# INLINE swapProdCons #-}

121

122type family IsProdCons (x :: Type) :: Bool where

123 IsProdCons (ProdCons _) = 'True

124 IsProdCons _ = 'False

125

126type SwapEnvElementRoles x = SwapEnvElementRoles' x (IsProdCons x)

127

128class IsProdCons x ~ f => SwapEnvElementRoles' (x :: Type) f where

129 swapEnvElementRoles :: x -> x

130

131instance SwapEnvElementRoles' (ProdCons x) 'True where

132 swapEnvElementRoles (ProdCons p c) = ProdCons c p

133

134instance IsProdCons x ~ 'False => SwapEnvElementRoles' x 'False where

135 swapEnvElementRoles = id

136

137class SwapEnvRoles xs where

138 swapEnvRoles :: HList xs -> HList xs

139

140instance SwapEnvRoles '[] where

141 swapEnvRoles = id

142

143instance (SwapEnvElementRoles x, SwapEnvRoles xs) => SwapEnvRoles (x ': xs) where

144 swapEnvRoles (HCons x xs) = HCons (swapEnvElementRoles x) (swapEnvRoles xs)

145

146instance Applicative ProdCons where

147 pure x = ProdCons x x

148 ProdCons fp fc <*> ProdCons xp xc = ProdCons (fp xp) (fc xc)

149

150newtype CompatM a = CompatM

151 { unCompatM

152 :: StateT (MemoState VarRef) Identity a

153 }

154 deriving newtype

155 ( Functor

156 , Applicative

157 , Monad

158 , MonadState (MemoState VarRef)

159 )

160

161type CompatFormula' q f r = Compose CompatM (FormulaF q f r)

162

163type SemanticCompatFormula = CompatFormula' Behave AnIssue 'APILevel

164

165type StructuralCompatFormula = CompatFormula' VoidQuiver Proxy ()

166

167data VoidQuiver a b

168

169deriving stock instance Eq (VoidQuiver a b)

170

171type instance AdditionalQuiverConstraints VoidQuiver _ _ = ()

172

173deriving stock instance Ord (VoidQuiver a b)

174

175deriving stock instance Show (VoidQuiver a b)

176

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

178 type CheckEnv t :: [Type]

179 type SubtreeLevel t :: BehaviorLevel

180

181 checkStructuralCompatibility

182 :: HList (CheckEnv t)

183 -> ProdCons (Traced t)

184 -> StructuralCompatFormula ()

185

186 checkSemanticCompatibility

187 :: HList (CheckEnv t)

188 -> Behavior (SubtreeLevel t)

189 -> ProdCons (Traced t)

190 -> SemanticCompatFormula ()

191

192{-# WARNING checkStructuralCompatibility "You should not be calling this directly. Use 'checkSubstructure'" #-}

193

194{-# WARNING checkSemanticCompatibility "You should not be calling this directly. Use 'checkCompatibility'" #-}

195

196checkCompatibility

197 :: forall t xs.

198 (ReassembleHList xs (CheckEnv t), Subtree t)

199 => Behavior (SubtreeLevel t)

200 -> HList xs

201 -> ProdCons (Traced t)

202 -> SemanticCompatFormula ()

203checkCompatibility bhv e = memo bhv SemanticMemoKey $ \pc ->

204 case runCompatFormula $ checkSubstructure e pc of

205 Left _ -> checkSemanticCompatibility (reassemble e) bhv pc

206 Right () -> pure ()

207{-# INLINE checkCompatibility #-}

208

209checkSubstructure

210 :: (ReassembleHList xs (CheckEnv t), Subtree t)

211 => HList xs

212 -> ProdCons (Traced t)

213 -> StructuralCompatFormula ()

214checkSubstructure e = memo Root StructuralMemoKey $ checkStructuralCompatibility (reassemble e)

215{-# INLINE checkSubstructure #-}

216

217structuralMaybe

218 :: (Subtree a, ReassembleHList xs (CheckEnv a))

219 => HList xs

220 -> ProdCons (Maybe (Traced a))

221 -> StructuralCompatFormula ()

222structuralMaybe e = structuralMaybeWith (checkSubstructure e)

223{-# INLINE structuralMaybe #-}

224

225structuralMaybeWith

226 :: (ProdCons a -> StructuralCompatFormula ())

227 -> ProdCons (Maybe a)

228 -> StructuralCompatFormula ()

229structuralMaybeWith f (ProdCons (Just a) (Just b)) = f $ ProdCons a b

230structuralMaybeWith _ (ProdCons Nothing Nothing) = pure ()

231structuralMaybeWith _ _ = structuralIssue

232{-# INLINE structuralMaybeWith #-}

233

234structuralList

235 :: (Subtree a, ReassembleHList xs (CheckEnv a))

236 => HList xs

237 -> ProdCons [Traced a]

238 -> StructuralCompatFormula ()

239structuralList _ (ProdCons [] []) = pure ()

240structuralList e (ProdCons (a : aa) (b : bb)) = do

241 checkSubstructure e $ ProdCons a b

242 structuralList e $ ProdCons aa bb

243 pure ()

244structuralList _ _ = structuralIssue

245{-# INLINE structuralList #-}

246

247structuralEq :: (Eq a, Comonad w) => ProdCons (w a) -> StructuralCompatFormula ()

248structuralEq (ProdCons a b) = if extract a == extract b then pure () else structuralIssue

249{-# INLINE structuralEq #-}

250

251iohmStructural

252 :: (ReassembleHList (k ': xs) (CheckEnv v), Ord k, Subtree v, Hashable k, Typeable k, Show k)

253 => HList xs

254 -> ProdCons (Traced (IOHM.InsOrdHashMap k v))

255 -> StructuralCompatFormula ()

256iohmStructural e =

257 iohmStructuralWith (\k -> checkSubstructure (k `HCons` e))

258{-# INLINE iohmStructural #-}

259

260instance (Typeable k, Typeable v, Ord k, Show k) => Steppable (IOHM.InsOrdHashMap k v) v where

261 data Step (IOHM.InsOrdHashMap k v) v = InsOrdHashMapKeyStep k

262 deriving stock (Eq, Ord, Show)

263

264iohmStructuralWith

265 :: (Ord k, Hashable k, Typeable k, Typeable v, Show k)

266 => (k -> ProdCons (Traced v) -> StructuralCompatFormula ())

267 -> ProdCons (Traced (IOHM.InsOrdHashMap k v))

268 -> StructuralCompatFormula ()

269iohmStructuralWith f pc = do

270 let ProdCons pEKeys cEKeys = S.fromList . IOHM.keys . extract <$> pc

271 if pEKeys == cEKeys

272 then

273 for_

274 pEKeys

275 (\eKey ->

276 f eKey $ stepTraced (InsOrdHashMapKeyStep eKey) . fmap (IOHM.lookupDefault (error "impossible") eKey) <$> pc)

277 else structuralIssue

278{-# INLINE iohmStructuralWith #-}

279

280runCompatFormula

281 :: CompatFormula' q f r a

282 -> Either (P.PathsPrefixTree q f r) a

283runCompatFormula (Compose f) =

284 calculate . runIdentity . runMemo 0 . unCompatM $ f

285{-# INLINE runCompatFormula #-}

286

287embedFormula :: Paths q r l -> CompatFormula' q f l a -> CompatFormula' q f r a

288embedFormula bhv (Compose x) = Compose $ mapErrors (P.embed bhv) <$> x

289

290issueAt :: Issuable l => Paths q r l -> Issue l -> CompatFormula' q AnIssue r a

291issueAt xs issue = Compose $ pure $ anError $ AnItem xs $ anIssue issue

292{-# INLINE issueAt #-}

293

294anIssue :: Issuable l => Issue l -> AnIssue l

295anIssue = AnIssue Forward

296{-# INLINE anIssue #-}

297

298anItem :: AnItem q AnIssue r -> CompatFormula' q AnIssue r a

299anItem = Compose . pure . anError

300{-# INLINE anItem #-}

301

302invertIssueOrientation :: CompatFormula' q AnIssue r a -> CompatFormula' q AnIssue r a

303invertIssueOrientation (Compose x) =

304 Compose $ mapErrors invertIssueOrientationP <$> x

305

306invertIssueOrientationP :: P.PathsPrefixTree q AnIssue r -> P.PathsPrefixTree q AnIssue r

307invertIssueOrientationP = P.map (\(AnIssue ori i) -> AnIssue (toggleOrientation ori) i)

308

309structuralIssue :: StructuralCompatFormula a

310structuralIssue = Compose $ pure $ anError $ AnItem Root Proxy

311

312anyOfAt

313 :: Issuable l

314 => Paths q r l

315 -> Issue l

316 -> [CompatFormula' q AnIssue r a]

317 -> CompatFormula' q AnIssue r a

318anyOfAt _ _ [x] = x

319anyOfAt xs issue fs =

320 Compose $ (`eitherOf` AnItem xs (anIssue issue)) <$> traverse getCompose fs

321

322-- | If the given formula contains any issues, add another issue on top. Otherwise succeed.

323clarifyIssue

324 :: AnItem q AnIssue r

325 -> CompatFormula' q AnIssue r a

326 -> CompatFormula' q AnIssue r a

327clarifyIssue item f =

328 Compose ((`eitherOf` item) <$> pure <$> getCompose f) *> f

329

330fixpointKnot

331 :: MonadState (MemoState VarRef) m

332 => KnotTier (FormulaF q f r ()) VarRef m

333fixpointKnot =

334 KnotTier

335 { onKnotFound = modifyMemoNonce succ

336 , onKnotUsed = \i -> pure $ variable i

337 , tieKnot = \i x -> pure $ maxFixpoint i x

338 }

339

340memo

341 :: (Typeable (l :: k), Typeable q, Typeable f, Typeable k, Typeable a)

342 => Paths q r l

343 -> MemoKey

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

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

346memo bhv k f pc = Compose $ do

347 formula' <-

348 memoWithKnot

349 fixpointKnot

350 (do

351 formula <- getCompose $ f pc

352 pure $ mapErrors (P.takeSubtree bhv) formula)

353 (k, ask <$> pc)

354 pure $ mapErrors (P.embed bhv) formula'

355

356data MemoKey = SemanticMemoKey | StructuralMemoKey

357 deriving stock (Eq, Ord)