Added JSON Path jets (#75)

* Updated ConstructReportJet variables

* changed ConstructReportJet yet more

* Added support for Union in jets

* Extracted jet args

* observeJetShowErrs'

* Complex Arguments

* Added branching

* Added JSON path jets

* Simplified things

* Better type rendering in report

.gitignore

@@ -2,3 +2,4 @@
 TAGS
 .vscode
 .dir-locals.el
+test/golden/common/prod

openapi-diff.cabal

@@ -64,6 +64,9 @@ common common-options
                      , yaml
                      , hashable
                      , pandoc-types
+                     , open-union
+                     , type-fun
+                     , free
 
   default-extensions: ApplicativeDo
                     , BangPatterns
@@ -137,6 +140,7 @@ library
                   , OpenAPI.Checker.Validate.SecurityScheme
                   , OpenAPI.Checker.Validate.OAuth2Flows
                   , OpenAPI.Checker.Report
+                  , Data.OpenUnion.Extra
 
 executable openapi-diff
   import:              common-options

src/Data/OpenUnion/Extra.hs

@@ -0,0 +1,43 @@
+module Data.OpenUnion.Extra
+  ( (@@>)
+  , TryLiftUnion (..)
+  , pattern SingletonUnion
+  )
+where
+
+import Control.Applicative
+import Data.Dynamic
+import Data.OpenUnion.Internal
+import Data.Typeable
+import TypeFun.Data.List hiding (Union)
+
+class TryLiftUnion xs where
+  tryLiftUnion :: (Alternative m, Typeable x) => x -> m (Union xs)
+
+instance TryLiftUnion '[] where
+  tryLiftUnion _ = empty
+
+instance
+  (Typeable y, SubList ys (y : ys), TryLiftUnion ys)
+  => TryLiftUnion (y ': ys)
+  where
+  tryLiftUnion (x :: x) = case eqT @x @y of
+    Nothing -> reUnion <$> tryLiftUnion @ys x
+    Just Refl -> pure $ liftUnion x
+
+-- | Like '@>', but enforces a specific type list order.
+-- (Useful for deconstruction-directed type inference.)
+(@@>) :: Typeable a => (a -> b) -> (Union xs -> b) -> Union (a ': xs) -> b
+r @@> l = either l r . restrict'
+  where
+    restrict' :: Typeable a => Union (a ': aa) -> Either (Union aa) a
+    restrict' (Union d) = maybe (Left $ Union d) Right $ fromDynamic d
+{-# INLINE (@@>) #-}
+
+infixr 2 @@>
+
+pattern SingletonUnion :: (Typeable a, Elem a s) => a -> Union s
+pattern SingletonUnion x <-
+  ((\(Union y) -> fromDynamic y) -> Just x)
+  where
+    SingletonUnion x = liftUnion x

src/OpenAPI/Checker/Report.hs

@@ -3,14 +3,22 @@ module OpenAPI.Checker.Report
   )
 where
 
+import Control.Applicative
+import Control.Monad.Free hiding (unfoldM)
 import Control.Monad.Reader
 import Control.Monad.Writer
+import Data.Either
 import Data.Foldable
+import Data.Function
 import Data.Functor
+import Data.List.NonEmpty
+import qualified Data.List.NonEmpty as NE
 import qualified Data.Map as M
 import Data.Maybe
+import Data.OpenUnion
+import Data.OpenUnion.Extra
+import Data.Text (Text)
 import qualified Data.Text as T
-import Data.Traversable
 import Data.TypeRepMap hiding (empty)
 import Data.Typeable
 import OpenAPI.Checker.Behavior
@@ -18,6 +26,7 @@ import OpenAPI.Checker.Paths
 import OpenAPI.Checker.PathsPrefixTree hiding (empty)
 import qualified OpenAPI.Checker.PathsPrefixTree as P hiding (empty)
 import OpenAPI.Checker.Validate.OpenApi
+import OpenAPI.Checker.Validate.Schema
 import Text.Pandoc.Builder
 
 generateReport :: Either (P.PathsPrefixTree Behave AnIssue 'APILevel) () -> Pandoc
@@ -25,13 +34,13 @@ generateReport (Right ()) = doc $ header 1 "No breaking changes found ✨"
 generateReport (Left errs) = doc $ runReportMonad jets $ showErrs errs
 
 data ReportState = ReportState
-  { sourceJets :: [SomeReportJet Behave]
+  { sourceJets :: [ReportJet' Behave Inlines]
   , headerLevel :: Int
   }
 
 type ReportMonad = ReaderT ReportState (Writer Blocks)
 
-runReportMonad :: [SomeReportJet Behave] -> ReportMonad () -> Blocks
+runReportMonad :: [ReportJet' Behave Inlines] -> ReportMonad () -> Blocks
 runReportMonad jts =
   execWriter
     . flip
@@ -46,11 +55,11 @@ smartHeader i = do
   h <- asks headerLevel
   tell $ header h i
 
-showErrs :: Typeable a => P.PathsPrefixTree Behave AnIssue a -> ReportMonad ()
+showErrs :: P.PathsPrefixTree Behave AnIssue a -> ReportMonad ()
 showErrs x@(P.PathsPrefixNode currentIssues _) = do
   jts <- asks sourceJets
   for_ currentIssues $ \(AnIssue i) -> tell . describeIssue $ i
-  unfoldM x (observeSomeJetShowErrs <$> jts) $ \(P.PathsPrefixNode _ subIssues) -> do
+  unfoldM x (observeJetShowErrs <$> jts) $ \(P.PathsPrefixNode _ subIssues) -> do
     for_ subIssues $ \(WrapTypeable (AStep m)) ->
       for_ (M.toList m) $ \(bhv, subErrors) -> do
         unless (P.null subErrors) $ do
@@ -63,74 +72,140 @@ unfoldM a (f : ff) g = do
   a' <- f a
   unfoldM a' ff g
 
-observeSomeJetShowErrs
-  :: forall a.
-  Typeable a
-  => SomeReportJet Behave
+observeJetShowErrs
+  :: ReportJet' Behave Inlines
   -> P.PathsPrefixTree Behave AnIssue a
   -> ReportMonad (P.PathsPrefixTree Behave AnIssue a)
-observeSomeJetShowErrs (SomeReportJet (Proxy :: Proxy a') f) x
-  | Just Refl <- eqT @a @a' = observeJetShowErrs f x
-observeSomeJetShowErrs _ x = pure x
+observeJetShowErrs jet p = case observeJetShowErrs' jet p of
+  Just m -> m
+  Nothing -> pure p
 
-observeJetShowErrs :: ReportJet Behave a -> P.PathsPrefixTree Behave AnIssue a -> ReportMonad (P.PathsPrefixTree Behave AnIssue a)
-observeJetShowErrs jet (P.PathsPrefixNode currentIssues subIssues) = do
-  rest <- fmap (fold . join) $
-    for subIssues $ \(WrapTypeable (AStep m)) -> fmap catMaybes $
-      for (M.toList m) $ \(bhv, subErrs) ->
-        case applyReportJet jet bhv of
-          Just (Left h) -> do
-            smartHeader h
-            incrementHeaders $ showErrs subErrs
-            return Nothing
-          Just (Right jet') -> do
-            rest <- observeJetShowErrs jet' subErrs
-            return $ Just $ embed (step bhv) rest
-          Nothing -> return $ Just $ embed (step bhv) subErrs
-  return $ PathsPrefixNode currentIssues mempty <> rest
+observeJetShowErrs'
+  :: forall a.
+     ReportJet' Behave Inlines
+  -> P.PathsPrefixTree Behave AnIssue a
+  -> Maybe (ReportMonad (P.PathsPrefixTree Behave AnIssue a))
+observeJetShowErrs' (ReportJet jet) (P.PathsPrefixNode currentIssues subIssues) =
+  let results =
+        subIssues >>= \(WrapTypeable (AStep m)) ->
+          M.toList m <&> \(bhv, subErrs) ->
+            maybe (Left $ embed (step bhv) subErrs) Right . listToMaybe $
+              jet @_ @_ @[] bhv
+                & mapMaybe
+                  (\case
+                     Free jet' -> fmap (embed $ step bhv) <$> observeJetShowErrs' jet' subErrs
+                     Pure h -> Just $ do
+                       smartHeader h
+                       incrementHeaders $ showErrs subErrs
+                       return mempty)
+   in (fmap . fmap) (PathsPrefixNode currentIssues mempty <>) $
+        if any isRight results
+          then
+            Just $
+              catMapM
+                (\case
+                   Left e -> pure e
+                   Right m -> m)
+                results
+          else Nothing
+
+catMapM :: (Monad m, Monoid b) => (a -> m b) -> [a] -> m b
+catMapM f xs = mconcat <$> mapM f xs
 
 -- | A "jet" is a way of simplifying expressions from "outside". The "jetted"
 -- expressions should still be completely valid and correct without the jets.
 -- Jets just make the expression more "optimized" by identifying patterns and
 -- replacing the expressions with "better" ones that have the same sematics.
 --
--- The tem "jet" in this context was introduced in the Urbit project:
+-- The term "jet" in this context was introduced in the Urbit project:
 --   https://urbit.org/docs/vere/jetting/
 --
 -- The pattern fits well for simplifying 'Behaviour' tree paths.
-class ConstructReportJet f a b c where
-  constructReportJet :: (f a b -> c) -> ReportJet f a
+class ConstructReportJet x f where
+  constructReportJet :: x -> ReportJetResult f Inlines
 
-instance (ConstructReportJet f b c d, Typeable b) => ConstructReportJet f a b (f b c -> d) where
-  constructReportJet f = ReportJet Proxy $ \x -> constructReportJet $ f x
+instance (ConstructReportJet b f, JetArg a) => ConstructReportJet (a -> b) f where
+  constructReportJet f = Free (fmap f <$> consumeJetArg @a) >>= constructReportJet
 
-instance Typeable b => ConstructReportJet f a b Inlines where
-  constructReportJet f = TerminalJet Proxy f
+instance ConstructReportJet Inlines f where
+  constructReportJet x = Pure x
 
-constructSomeReportJet :: (ConstructReportJet f a b c, Typeable a) => (f a b -> c) -> SomeReportJet f
-constructSomeReportJet = SomeReportJet Proxy . constructReportJet
+class JetArg a where
+  consumeJetArg :: ReportJet' f a
 
-data ReportJet f a where
-  ReportJet :: Typeable b => Proxy b -> (f a b -> ReportJet f b) -> ReportJet f a
-  TerminalJet :: Typeable b => Proxy b -> (f a b -> Inlines) -> ReportJet f a
+instance Typeable (f a b) => JetArg (f a b) where
+  consumeJetArg =
+    ReportJet $ \(x :: x) ->
+      case eqT @(f a b) @x of
+        Nothing -> empty
+        Just Refl -> pure $ Pure x
 
-data SomeReportJet f where
-  SomeReportJet :: Typeable a => Proxy a -> ReportJet f a -> SomeReportJet f
+instance TryLiftUnion xs => JetArg (Union xs) where
+  consumeJetArg = ReportJet $ fmap Pure . tryLiftUnion
 
-applyReportJet :: forall f a b. Typeable b => ReportJet f a -> f a b -> Maybe (Either Inlines (ReportJet f b))
-applyReportJet (TerminalJet (Proxy :: Proxy b') f) x = eqT @b @b' <&> \Refl -> Left $ f x
-applyReportJet (ReportJet (Proxy :: Proxy b') f) x = eqT @b @b' <&> \Refl -> Right $ f x
+instance JetArg x => JetArg (NonEmpty x) where
+  consumeJetArg =
+    let (ReportJet f) = (consumeJetArg @x)
+     in ReportJet $ \a -> do
+          u <- f a
+          pure (u >>= \y -> Free $ fmap (NE.cons y) <$> consumeJetArg)
+            <|> pure (pure <$> u)
+
+type ReportJetResult f = Free (ReportJet f)
+
+-- Not a true 'Applicative'
+newtype ReportJet f x = ReportJet (forall a b m. (Typeable (f a b), Alternative m, Monad m) => f a b -> m x)
+  deriving stock (Functor)
+
+type ReportJet' f a = ReportJet f (Free (ReportJet f) a)
 
 incrementHeaders :: ReportMonad x -> ReportMonad x
 incrementHeaders m = do
   l <- asks headerLevel
   local (\x -> x {headerLevel = l + 1}) m
 
-jets :: [SomeReportJet Behave]
+jets :: [ReportJet' Behave Inlines]
 jets =
-  [ constructSomeReportJet $ \p@(AtPath _) op@(InOperation _) ->
-      strong (describeBehaviour op) <> " " <> describeBehaviour p :: Inlines
-  , constructSomeReportJet $ \InRequest InPayload PayloadSchema -> "JSON Request" :: Inlines
-  , constructSomeReportJet $ \(WithStatusCode c) ResponsePayload PayloadSchema ->
-      "JSON Response – " <> str (T.pack . show $ c) :: Inlines
-  ]
+  unwrapReportJetResult
+    <$> [ constructReportJet jsonPathJet
+        , constructReportJet $ \p@(AtPath _) op@(InOperation _) ->
+            strong (describeBehaviour op) <> " " <> describeBehaviour p :: Inlines
+        , constructReportJet $ \InRequest InPayload PayloadSchema -> "JSON Request" :: Inlines
+        , constructReportJet $ \(WithStatusCode c) ResponsePayload PayloadSchema ->
+            "JSON Response – " <> str (T.pack . show $ c) :: Inlines
+        ]
+  where
+    unwrapReportJetResult :: ReportJetResult Behave x -> ReportJet' Behave x
+    unwrapReportJetResult (Pure _) = error "There really shouldn't be any results here."
+    unwrapReportJetResult (Free f) = f
+
+    jsonPathJet
+      :: NonEmpty
+           ( Union
+               '[ Behave 'SchemaLevel 'TypedSchemaLevel
+                , Behave 'TypedSchemaLevel 'SchemaLevel
+                ]
+           )
+      -> Inlines
+    jsonPathJet x = code $ "$" <> showParts (NE.toList x)
+      where
+        showParts
+          :: [ Union
+                 '[ Behave 'SchemaLevel 'TypedSchemaLevel
+                  , Behave 'TypedSchemaLevel 'SchemaLevel
+                  ]
+             ]
+          -> Text
+        showParts [] = mempty
+        showParts (SingletonUnion (OfType Object) : xs@((SingletonUnion (InProperty _)) : _)) = showParts xs
+        showParts (SingletonUnion (OfType Object) : xs@((SingletonUnion InAdditionalProperty) : _)) = showParts xs
+        showParts (SingletonUnion (OfType Array) : xs@(SingletonUnion InItems : _)) = showParts xs
+        showParts (y : ys) =
+          ((\(OfType t) -> "(" <> describeJSONType t <> ")")
+             @@> (\case
+                    InItems -> "[*]"
+                    InProperty p -> "." <> p
+                    InAdditionalProperty -> ".*")
+             @@> typesExhausted)
+            y
+            <> showParts ys

src/OpenAPI/Checker/Validate/Schema.hs

@@ -10,6 +10,8 @@ module OpenAPI.Checker.Validate.Schema
   , Bound (..)
   , schemaToFormula
   , foldLattice
+  , Behave (..)
+  , describeJSONType
   )
 where
 
@@ -39,6 +41,7 @@ import Data.Ord
 import Data.Ratio
 import Data.Scientific
 import qualified Data.Set as S
+import Data.String
 import Data.Text (Text)
 import qualified Data.Text as T hiding (singleton)
 import qualified Data.Text.Encoding as T
@@ -1110,7 +1113,7 @@ instance Behavable 'SchemaLevel 'TypedSchemaLevel where
 
   describeBehaviour (OfType t) = describeJSONType t
 
-describeJSONType :: JsonType -> Inlines
+describeJSONType :: IsString s => JsonType -> s
 describeJSONType = \case
   Null -> "Null"
   Boolean -> "Boolean"

stack.yaml

@@ -1 +1,5 @@
 resolver: nightly-2021-06-01
+
+extra-deps:
+  - open-union-0.4.0.0
+  - type-fun-0.1.3

stack.yaml.lock

@@ -3,7 +3,21 @@
 # For more information, please see the documentation at:
 #   https://docs.haskellstack.org/en/stable/lock_files
 
-packages: []
+packages:
+- completed:
+    hackage: open-union-0.4.0.0@sha256:1c8f8090054b0974e95e44bed88e74fff956ba2120aade6e8deea92d65ef5e49,3503
+    pantry-tree:
+      size: 329
+      sha256: e01838ec41f7aa2a97aa2c3586c8188c4ad093ba0b2be41229ab7b8dbd33869e
+  original:
+    hackage: open-union-0.4.0.0
+- completed:
+    hackage: type-fun-0.1.3@sha256:336b851757792f201078043210aec180021ac052f0955c71fa330a5fe11b0604,1765
+    pantry-tree:
+      size: 583
+      sha256: b977d42525f0b4223959918d18e7905085283e937493c395077b608cd19b42c1
+  original:
+    hackage: type-fun-0.1.3
 snapshots:
 - completed:
     size: 587963

test/golden/common/maximum-lowered/report.md

@@ -2,6 +2,6 @@
 
 ## JSON Request
 
-### Number
+### `$(Number)`
 
 Expected upper bound 3.0 inclusive but but found 2.0 inclusive.

test/golden/common/pathItem/operation/parameters/change/report.md

@@ -4,6 +4,6 @@
 
 ### JSON Schema
 
-#### String
+#### `$(String)`
 
 Expected the type to be allowed, but it wasn't.

test/golden/common/pathItem/operation/requestBody/mediaTypeObject/change/report.md

@@ -2,6 +2,6 @@
 
 ## JSON Request
 
-### String
+### `$(String)`
 
 Expected the type to be allowed, but it wasn't.

test/golden/common/pathItem/operation/responses/change/mediaTypeObject/change/report.md

@@ -2,6 +2,6 @@
 
 ## JSON Response – 200
 
-### Number
+### `$(Number)`
 
 Expected the type to be allowed, but it wasn't.

test/golden/common/property-removed/report.md

@@ -2,12 +2,12 @@
 
 ## JSON Request
 
-### Object
+### `$(Object)`
 
 Expected the property `property2` to be allowed, but it wasn't.
 
 ## JSON Response – 200
 
-### Object
+### `$(Object)`
 
 Don't have a required property `property2`.

test/golden/common/property-required/report.md

@@ -2,6 +2,6 @@
 
 ## JSON Request
 
-### Object
+### `$(Object)`
 
 Don't have a required property `property2`.