Actually format all code

app/Data/OpenApi/Compare/Options.hs

@@ -1,7 +1,7 @@
 module Data.OpenApi.Compare.Options
-  ( Options (..)
-  , OutputMode (..)
-  , parseOptions
+  ( Options (..),
+    OutputMode (..),
+    parseOptions,
   )
 where
 
@@ -30,86 +30,105 @@ optionsParserInfo :: ParserInfo Options
 optionsParserInfo =
   info
     (helper <*> optionsParser)
-    (fullDesc
-       <> header "CompaREST"
-       <> progDescDoc
-         (Just $
-            par "A tool to check compatibility between two OpenAPI specifications."
-              <$$> hardline <> par "Usage examples" <> hardline
-              <$$> indent
-                4
-                (par "Compare files old.yaml with new.yaml and output the resulting report to stdout:"
-                   <$$> hardline <> indent 4 "comparest -c old.yaml -s new.yaml"
-                   <$$> hardline <> par "Only output breaking changes and write a styled HTML report to file report.html:"
-                   <$$> hardline <> indent 4 "comparest -c old.yaml -s new.yaml --only-breaking -o report"
-                   <$$> hardline <> par "Don't output anything, only fail if there are breaking changes:"
-                   <$$> hardline <> indent 4 "comparest -c old.json -s new.json --silent"
-                   <$$> hardline <> par "Write full report suitable for embedding into a GitHub comment to report.html:"
-                   <$$> hardline <> indent 4 "comparest -c old.json -s new.json --folding-block-quotes-style -o report.html")))
+    ( fullDesc
+        <> header "CompaREST"
+        <> progDescDoc
+          ( Just $
+              par "A tool to check compatibility between two OpenAPI specifications."
+                <$$> hardline <> par "Usage examples" <> hardline
+                <$$> indent
+                  4
+                  ( par "Compare files old.yaml with new.yaml and output the resulting report to stdout:"
+                      <$$> hardline <> indent 4 "comparest -c old.yaml -s new.yaml"
+                      <$$> hardline <> par "Only output breaking changes and write a styled HTML report to file report.html:"
+                      <$$> hardline <> indent 4 "comparest -c old.yaml -s new.yaml --only-breaking -o report"
+                      <$$> hardline <> par "Don't output anything, only fail if there are breaking changes:"
+                      <$$> hardline <> indent 4 "comparest -c old.json -s new.json --silent"
+                      <$$> hardline <> par "Write full report suitable for embedding into a GitHub comment to report.html:"
+                      <$$> hardline <> indent 4 "comparest -c old.json -s new.json --folding-block-quotes-style -o report.html"
+                  )
+          )
+    )
 
 optionsParser :: Parser Options
 optionsParser =
   Options
     <$> strOption
-      (short 'c'
-         <> long "client"
-         <> help
-           "A path to the file containing the specification that will be \
-           \used for the client of the API. Can be either a YAML or JSON file.")
+      ( short 'c'
+          <> long "client"
+          <> help
+            "A path to the file containing the specification that will be \
+            \used for the client of the API. Can be either a YAML or JSON file."
+      )
     <*> strOption
-      (short 's'
-         <> long "server"
-         <> help
-           "A path to the file containing the specification that will be \
-           \used for the server of the API. Can be either a YAML or JSON file.")
-    <*> (flag'
-           Nothing
-           (long "silent"
-              <> help "Silence all output. Only makes sense in combination with --signal-exit-code.")
-           <|> flag'
-             (Just OnlyErrors)
-             (long "only-breaking"
-                <> help "Only report breaking changes in the output.")
-           <|> flag'
-             (Just All)
-             (long "all"
-                <> help
-                  "Report both incompatible and compatible changes. \
-                  \Compatible changes will not trigger a failure exit code.")
-           <|> pure (Just All))
-    <*> ((FileMode
-            <$> strOption
-              (short 'o' <> long "output"
-                 <> helpDoc
-                   (Just $
-                      par "The file path where the output should be written. If the option is omitted the result will be written to stdout."
-                        <$$> hardline <> par "The file extension is used to determine the type of the output file."
-                        <$$> hardline <> par "Supports many formats such as markdown, html, rtf, doc, txt, rst, and many more."
-                        <$$> hardline <> par "Leave out the extension to produce a self-contained HTML report with styling.")))
-           <|> pure StdoutMode)
-    <*> (flag'
-           FoldingBlockquotesTreeStyle
-           (long "folding-block-quotes-style"
-              <> help
-                "The report tree is structured using \
-                \summary/detail HTML elements and indented using \
-                \block quotes. This style renders well on GitHub.\
-                \Intended for HTML output format. Markdown has rendering \
-                \bugs on GitHub.")
-           <|> flag'
-             HeadersTreeStyle
-             (long "header-style"
+      ( short 's'
+          <> long "server"
+          <> help
+            "A path to the file containing the specification that will be \
+            \used for the server of the API. Can be either a YAML or JSON file."
+      )
+    <*> ( flag'
+            Nothing
+            ( long "silent"
+                <> help "Silence all output. Only makes sense in combination with --signal-exit-code."
+            )
+            <|> flag'
+              (Just OnlyErrors)
+              ( long "only-breaking"
+                  <> help "Only report breaking changes in the output."
+              )
+            <|> flag'
+              (Just All)
+              ( long "all"
+                  <> help
+                    "Report both incompatible and compatible changes. \
+                    \Compatible changes will not trigger a failure exit code."
+              )
+            <|> pure (Just All)
+        )
+    <*> ( ( FileMode
+              <$> strOption
+                ( short 'o' <> long "output"
+                    <> helpDoc
+                      ( Just $
+                          par "The file path where the output should be written. If the option is omitted the result will be written to stdout."
+                            <$$> hardline <> par "The file extension is used to determine the type of the output file."
+                            <$$> hardline <> par "Supports many formats such as markdown, html, rtf, doc, txt, rst, and many more."
+                            <$$> hardline <> par "Leave out the extension to produce a self-contained HTML report with styling."
+                      )
+                )
+          )
+            <|> pure StdoutMode
+        )
+    <*> ( flag'
+            FoldingBlockquotesTreeStyle
+            ( long "folding-block-quotes-style"
                 <> help
                   "The report tree is structured using \
-                  \increasing levels of headers.")
-           <|> pure HeadersTreeStyle)
-    <*> switch 
-        (long "signal-exit-code"
-            <> helpDoc (Just $ 
+                  \summary/detail HTML elements and indented using \
+                  \block quotes. This style renders well on GitHub.\
+                  \Intended for HTML output format. Markdown has rendering \
+                  \bugs on GitHub."
+            )
+            <|> flag'
+              HeadersTreeStyle
+              ( long "header-style"
+                  <> help
+                    "The report tree is structured using \
+                    \increasing levels of headers."
+              )
+            <|> pure HeadersTreeStyle
+        )
+    <*> switch
+      ( long "signal-exit-code"
+          <> helpDoc
+            ( Just $
                 par "Signal API compatibility with the exit code."
                   <$$> hardline <> par "Exit with 0 if there are no breaking changes."
                   <$$> par "Exit with 1 if there are breaking changes."
-                  <$$> par "Exit with 2 if could not determine compatibility."))
+                  <$$> par "Exit with 2 if could not determine compatibility."
+            )
+      )
 
 par :: String -> Doc
 par = foldr1 (</>) . fmap string . words

app/FormatHeuristic.hs

@@ -2,7 +2,7 @@
 -- Originally based on:
 --   https://github.com/jgm/pandoc/blob/master/src/Text/Pandoc/App/FormatHeuristics.hs
 module FormatHeuristic
-  ( formatFromFilePath
+  ( formatFromFilePath,
   )
 where
 

src/Data/HList.hs

@@ -1,11 +1,11 @@
 module Data.HList
-  ( Has
-  , HasAll
-  , getH
-  , HList (..)
-  , singletonH
-  , ReassembleHList
-  , reassemble
+  ( Has,
+    HasAll,
+    getH,
+    HList (..),
+    singletonH,
+    ReassembleHList,
+    reassemble,
   )
 where
 
@@ -40,8 +40,8 @@ instance (Has' x xs t, HeadEq x (y : xs) ~ 'False) => Has' x (y ': xs) 'False wh
   {-# INLINE getH #-}
 
 instance
-  TypeError ('ShowType x ':<>: 'Text " is not a part of the list.")
-  => Has' x '[] 'False
+  TypeError ( 'ShowType x ':<>: 'Text " is not a part of the list.") =>
+  Has' x '[] 'False
   where
   getH HNil = undefined
   {-# INLINE getH #-}
@@ -74,8 +74,8 @@ instance ReassembleHList' (x ': xs) '[] 'False where
   {-# INLINE reassemble #-}
 
 instance
-  (Has y xs, ReassembleHList' xs ys f, (xs == (y ': ys)) ~ 'False)
-  => ReassembleHList' xs (y ': ys) 'False
+  (Has y xs, ReassembleHList' xs ys f, (xs == (y ': ys)) ~ 'False) =>
+  ReassembleHList' xs (y ': ys) 'False
   where
   reassemble xs = getH @y xs `HCons` reassemble xs
   {-# INLINE reassemble #-}

src/Data/OpenApi/Compare/Behavior.hs

@@ -1,15 +1,15 @@
 module Data.OpenApi.Compare.Behavior
-  ( BehaviorLevel (..)
-  , Behavable (..)
-  , IssueKind (..)
-  , Issuable (..)
-  , Orientation (..)
-  , toggleOrientation
-  , Behavior
-  , AnIssue (..)
-  , withClass
-  , anIssueKind
-  , relatedAnIssues
+  ( BehaviorLevel (..),
+    Behavable (..),
+    IssueKind (..),
+    Issuable (..),
+    Orientation (..),
+    toggleOrientation,
+    Behavior,
+    AnIssue (..),
+    withClass,
+    anIssueKind,
+    relatedAnIssues,
   )
 where
 

src/Data/OpenApi/Compare/Common.hs

@@ -1,5 +1,5 @@
 module Data.OpenApi.Compare.Common
-  ( zipAll
+  ( zipAll,
   )
 where
 

src/Data/OpenApi/Compare/Formula.hs

@@ -1,14 +1,15 @@
 module Data.OpenApi.Compare.Formula
-  ( FormulaF
-  , VarRef
-  , variable
-  , eitherOf
-  , anError
-  , errors
-  , calculate
-  , maxFixpoint
-  , mapErrors
-  ) where
+  ( FormulaF,
+    VarRef,
+    variable,
+    eitherOf,
+    anError,
+    errors,
+    calculate,
+    maxFixpoint,
+    mapErrors,
+  )
+where
 
 import Data.Kind
 import qualified Data.List.NonEmpty as NE
@@ -24,15 +25,24 @@ type VarRef = Int
 -- fixpoints always exist, i.e. that @x = f x@ has at least one solution.
 data FormulaF (q :: k -> k -> Type) (f :: k -> Type) (r :: k) (a :: Type) where
   Result :: a -> FormulaF q f r a
-  Errors :: !(P.PathsPrefixTree q f r) -> FormulaF q f r a
-    -- ^ invariant: never empty
-  Apply :: FormulaF q f r (b -> c) -> FormulaF q f r b -> (c -> a) -> FormulaF q f r a
-    -- ^ invariant: at least one of LHS and RHS is not 'Errors', and they are
+  Errors ::
+    !(P.PathsPrefixTree q f r) ->
+    -- | invariant: never empty
+    FormulaF q f r a
+  Apply ::
+    FormulaF q f r (b -> c) ->
+    FormulaF q f r b ->
+    (c -> a) ->
+    -- | invariant: at least one of LHS and RHS is not 'Errors', and they are
     -- both not 'Result'
-  SelectFirst :: NE.NonEmpty (SomeFormulaF b)
-    -> !(P.PathsPrefixTree q f r) -> (b -> a) -> FormulaF q f r a
-    -- ^ invariant: the list doesn't contain any 'Result's, 'Errors' or
+    FormulaF q f r a
+  SelectFirst ::
+    NE.NonEmpty (SomeFormulaF b) ->
+    !(P.PathsPrefixTree q f r) ->
+    (b -> a) ->
+    -- | invariant: the list doesn't contain any 'Result's, 'Errors' or
     -- 'SelectFirst'
+    FormulaF q f r a
   Variable :: !VarRef -> a -> FormulaF q f r a
 
 mkApply :: FormulaF q f r (b -> c) -> FormulaF q f r b -> (c -> a) -> FormulaF q f r a
@@ -44,13 +54,13 @@ mkApply f x h = Apply f x h
 mkSelectFirst :: [SomeFormulaF b] -> P.PathsPrefixTree q f r -> (b -> a) -> FormulaF q f r a
 mkSelectFirst fs allE h = case foldMap check fs of
   (First (Just x), _) -> Result (h x)
-  (First Nothing, x:xs) -> SelectFirst (x NE.:| xs) allE h
+  (First Nothing, x : xs) -> SelectFirst (x NE.:| xs) allE h
   (First Nothing, []) -> Errors allE
   where
     check (SomeFormulaF (Result x)) = (First (Just x), mempty)
     check (SomeFormulaF (Errors _)) = (mempty, mempty)
-    check (SomeFormulaF (SelectFirst xs _ h'))
-      = (mempty, NE.toList (fmap (fmap h') xs))
+    check (SomeFormulaF (SelectFirst xs _ h')) =
+      (mempty, NE.toList (fmap (fmap h') xs))
     check x = (mempty, [x])
 
 data SomeFormulaF (a :: Type) where
@@ -96,7 +106,7 @@ calculate (Apply f x h) = case calculate f of
     Right x' -> Right (h (f' x'))
 calculate (SelectFirst xs e h) = go (NE.toList xs)
   where
-    go (SomeFormulaF r:rs) = case calculate r of
+    go (SomeFormulaF r : rs) = case calculate r of
       Left _ -> go rs
       Right x -> Right (h x)
     go [] = Left e

src/Data/OpenApi/Compare/Memo.hs

@@ -1,22 +1,24 @@
 {-# LANGUAGE AllowAmbiguousTypes #-}
+
 -- | Utilities for effectfully memoizing other, more effectful functions.
 module Data.OpenApi.Compare.Memo
-  ( MonadMemo
-  , MemoState
-  , runMemo
-  , modifyMemoNonce
-  , KnotTier(..)
-  , unknot
-  , memoWithKnot
-  , memoTaggedWithKnot
-  ) where
+  ( MonadMemo,
+    MemoState,
+    runMemo,
+    modifyMemoNonce,
+    KnotTier (..),
+    unknot,
+    memoWithKnot,
+    memoTaggedWithKnot,
+  )
+where
 
 import Control.Monad.State
 import Data.Dynamic
 import qualified Data.Map as M
 import Data.Tagged
-import Data.Void
 import qualified Data.TypeRepMap as T
+import Data.Void
 import Type.Reflection
 
 data Progress a = Finished a | Started | TyingKnot Dynamic
@@ -29,16 +31,23 @@ data MemoState s = MemoState s (T.TypeRepMap MemoMap)
 -- | An effectful memoization monad.
 type MonadMemo s m = MonadState (MemoState s) m
 
-memoStateLookup
-  :: forall k v s. (Typeable k, Typeable v, Ord k)
-  => k -> MemoState s -> Maybe (Progress v)
+memoStateLookup ::
+  forall k v s.
+  (Typeable k, Typeable v, Ord k) =>
+  k ->
+  MemoState s ->
+  Maybe (Progress v)
 memoStateLookup k (MemoState _ t) = case T.lookup @(k, v) t of
   Just (MemoMap m) -> M.lookup k m
   Nothing -> Nothing
 
-memoStateInsert
-  :: forall k v s. (Typeable k, Typeable v, Ord k)
-  => k -> Progress v -> MemoState s -> MemoState s
+memoStateInsert ::
+  forall k v s.
+  (Typeable k, Typeable v, Ord k) =>
+  k ->
+  Progress v ->
+  MemoState s ->
+  MemoState s
 memoStateInsert k x (MemoState s t) = MemoState s $ T.insert (MemoMap m'') t
   where
     m'' = M.insert k x m'
@@ -59,19 +68,23 @@ runMemo s = (`evalStateT` MemoState s T.empty)
 -- | A description of how to effectfully tie knots in type @v@, using the @m@
 -- monad, and by sharing some @d@ data among the recursive instances.
 data KnotTier v d m = KnotTier
-  { onKnotFound :: m d -- ^ Create some data that will be connected to this knot
-  , onKnotUsed :: d -> m v -- ^ This is what the knot will look like as a value
+  { -- | Create some data that will be connected to this knot
+    onKnotFound :: m d
+  , -- | This is what the knot will look like as a value
     -- to the inner computations
-  , tieKnot :: d -> v -> m v -- ^ Once we're done and we're outside, tie the
+    onKnotUsed :: d -> m v
+  , -- | Once we're done and we're outside, tie the
     -- knot using the datum
+    tieKnot :: d -> v -> m v
   }
 
 unknot :: KnotTier v Void m
-unknot = KnotTier
-  { onKnotFound = error "Recursion detected"
-  , onKnotUsed = absurd
-  , tieKnot = absurd
-  }
+unknot =
+  KnotTier
+    { onKnotFound = error "Recursion detected"
+    , onKnotUsed = absurd
+    , tieKnot = absurd
+    }
 
 -- | Run a potentially recursive computation. The provided key will be used to
 -- refer to the result of this computation. If during the computation, another
@@ -80,47 +93,72 @@ unknot = KnotTier
 --
 -- If another attempt to run the computation with the same key is made
 -- *after we're done*, we will return the memoized value.
-memoWithKnot
-  :: forall k v d m s.
-    (Typeable k, Typeable v, Typeable d, Ord k, MonadMemo s m)
-  => KnotTier v d m
-  -> m v -- ^ the computation to memoize
-  -> k -- ^ key for memoization
-  -> m v
-memoWithKnot tier f k = memoStateLookup @k @v k <$> get >>= \case
-  Just (Finished v) -> pure v
-  Just Started -> do
-    d <- onKnotFound tier
-    modify $ memoStateInsert @k @v k (TyingKnot $ toDyn d)
-    onKnotUsed tier d
-  Just (TyingKnot dyn) -> case fromDynamic dyn of
-    Just d -> onKnotUsed tier d
-    Nothing -> error $ "Type mismatch when examining the knot of "
-      <> show (typeRep @(k -> v)) <> ": expected " <> show (typeRep @d)
-      <> ", got " <> show (dynTypeRep dyn)
-  Nothing -> do
-    modify $ memoStateInsert @k @v k Started
-    v <- f
-    v' <- memoStateLookup @k @v k <$> get >>= \case
-      Just Started -> pure v
-      Just (TyingKnot dyn) -> case fromDynamic dyn of
-        Just d -> tieKnot tier d v
-        Nothing -> error $ "Type mismatch when tying the knot of "
-          <> show (typeRep @(k -> v)) <> ": expected " <> show (typeRep @d)
-          <> ", got " <> show (dynTypeRep dyn)
-      Just (Finished _) -> error $ "Unexpected Finished when memoizing "
-          <> show (typeRep @(k -> v))
-      Nothing -> pure v
-        -- Normally this would be an error, but the underlying monad can refuse
-        -- to remember memoization state
-    modify $ memoStateInsert @k @v k (Finished v')
-    pure v'
+memoWithKnot ::
+  forall k v d m s.
+  (Typeable k, Typeable v, Typeable d, Ord k, MonadMemo s m) =>
+  KnotTier v d m ->
+  -- | the computation to memoize
+  m v ->
+  -- | key for memoization
+  k ->
+  m v
+memoWithKnot tier f k =
+  memoStateLookup @k @v k <$> get >>= \case
+    Just (Finished v) -> pure v
+    Just Started -> do
+      d <- onKnotFound tier
+      modify $ memoStateInsert @k @v k (TyingKnot $ toDyn d)
+      onKnotUsed tier d
+    Just (TyingKnot dyn) -> case fromDynamic dyn of
+      Just d -> onKnotUsed tier d
+      Nothing ->
+        error $
+          "Type mismatch when examining the knot of "
+            <> show (typeRep @(k -> v))
+            <> ": expected "
+            <> show (typeRep @d)
+            <> ", got "
+            <> show (dynTypeRep dyn)
+    Nothing -> do
+      modify $ memoStateInsert @k @v k Started
+      v <- f
+      v' <-
+        memoStateLookup @k @v k <$> get >>= \case
+          Just Started -> pure v
+          Just (TyingKnot dyn) -> case fromDynamic dyn of
+            Just d -> tieKnot tier d v
+            Nothing ->
+              error $
+                "Type mismatch when tying the knot of "
+                  <> show (typeRep @(k -> v))
+                  <> ": expected "
+                  <> show (typeRep @d)
+                  <> ", got "
+                  <> show (dynTypeRep dyn)
+          Just (Finished _) ->
+            error $
+              "Unexpected Finished when memoizing "
+                <> show (typeRep @(k -> v))
+          Nothing -> pure v
+      -- Normally this would be an error, but the underlying monad can refuse
+      -- to remember memoization state
+      modify $ memoStateInsert @k @v k (Finished v')
+      pure v'
 
 -- | Disambiguate memoized computations with an arbitrary tag.
-memoTaggedWithKnot
-  :: forall t k v d m s.
-    ( Typeable t, Typeable k, Typeable v, Typeable d
-    , Ord k, MonadMemo s m )
-  => KnotTier v d m -> m v -> k -> m v
-memoTaggedWithKnot tier f k = withTypeable (typeRepKind $ typeRep @t) $
-  memoWithKnot tier f (Tagged @t k)
+memoTaggedWithKnot ::
+  forall t k v d m s.
+  ( Typeable t
+  , Typeable k
+  , Typeable v
+  , Typeable d
+  , Ord k
+  , MonadMemo s m
+  ) =>
+  KnotTier v d m ->
+  m v ->
+  k ->
+  m v
+memoTaggedWithKnot tier f k =
+  withTypeable (typeRepKind $ typeRep @t) $
+    memoWithKnot tier f (Tagged @t k)

src/Data/OpenApi/Compare/Paths.hs

@@ -2,17 +2,17 @@
 -- collection of datatypes that "contain" eachother in some form of tree
 -- structure.
 module Data.OpenApi.Compare.Paths
-  ( NiceQuiver
-  , AdditionalQuiverConstraints
-  , Paths (..)
-  , DiffPaths (..)
-  , catDiffPaths
-  , AnItem (..)
-  , step
+  ( NiceQuiver,
+    AdditionalQuiverConstraints,
+    Paths (..),
+    DiffPaths (..),
+    catDiffPaths,
+    AnItem (..),
+    step,
 
     -- * Reexports
-  , (>>>)
-  , (<<<)
+    (>>>),
+    (<<<),
   )
 where
 

src/Data/OpenApi/Compare/PathsPrefixTree.hs

@@ -1,22 +1,22 @@
 {-# LANGUAGE QuantifiedConstraints #-}
 
 module Data.OpenApi.Compare.PathsPrefixTree
-  ( PathsPrefixTree (PathsPrefixNode)
-  , AStep (..)
-  , empty
-  , singleton
-  , fromList
-  , null
-  , foldWith
-  , toList
-  , filter
-  , filterWithKey
-  , takeSubtree
-  , lookup
-  , embed
-  , size
-  , partition
-  , map
+  ( PathsPrefixTree (PathsPrefixNode),
+    AStep (..),
+    empty,
+    singleton,
+    fromList,
+    null,
+    foldWith,
+    toList,
+    filter,
+    filterWithKey,
+    takeSubtree,
+    lookup,
+    embed,
+    size,
+    partition,
+    map,
   )
 where
 
@@ -35,7 +35,7 @@ import qualified Data.TypeRepMap as TRM
 import qualified Data.Vector as V
 import qualified GHC.Exts as Exts
 import Type.Reflection
-import Prelude hiding (filter, map, null, lookup)
+import Prelude hiding (filter, lookup, map, null)
 
 -- | A list of @AnItem r f@, but optimized into a prefix tree.
 data PathsPrefixTree (q :: k -> k -> Type) (f :: k -> Type) (r :: k) = PathsPrefixTree
@@ -102,11 +102,11 @@ deriving stock instance Eq (PathsPrefixTree q f a)
 
 -- Kind of orphan. Treat the map as an infinite tuple of @Maybe (f a)@'s, where
 -- the components are ordered by the @SomeTypeRep@ of the @a@.
-compareTRM
-  :: (forall a. Typeable a => Ord (f a))
-  => TRM.TypeRepMap f
-  -> TRM.TypeRepMap f
-  -> Ordering
+compareTRM ::
+  (forall a. Typeable a => Ord (f a)) =>
+  TRM.TypeRepMap f ->
+  TRM.TypeRepMap f ->
+  Ordering
 compareTRM s1 s2 =
   foldMap (\k -> compareMaybe compareW (M.lookup k m1) (M.lookup k m2)) mKeys
   where
@@ -116,11 +116,11 @@ compareTRM s1 s2 =
     compareMaybe _ Nothing (Just _) = LT
     compareMaybe _ (Just _) Nothing = GT
     compareMaybe cmp (Just x) (Just y) = cmp x y
-    compareW
-      :: (forall a. Typeable a => Ord (f a))
-      => TRM.WrapTypeable f
-      -> TRM.WrapTypeable f
-      -> Ordering
+    compareW ::
+      (forall a. Typeable a => Ord (f a)) =>
+      TRM.WrapTypeable f ->
+      TRM.WrapTypeable f ->
+      Ordering
     compareW (TRM.WrapTypeable (x :: f a)) (TRM.WrapTypeable (y :: f b))
       | Just Refl <- testEquality (typeRep @a) (typeRep @b) = compare x y
       | otherwise = EQ -- unreachable
@@ -172,10 +172,10 @@ instance Monoid (ASet a) where
   mempty = AnEmptySet
 
 data AStep (q :: k -> k -> Type) (f :: k -> Type) (r :: k) (a :: k) where
-  AStep
-    :: NiceQuiver q r a =>
-    !(M.Map (q r a) (PathsPrefixTree q f a))
-    -> AStep q f r a
+  AStep ::
+    NiceQuiver q r a =>
+    !(M.Map (q r a) (PathsPrefixTree q f a)) ->
+    AStep q f r a
 
 mapAStep :: (forall x. f x -> f x) -> AStep q f r a -> AStep q f r a
 mapAStep f (AStep m) = AStep $ M.map (map f) m
@@ -215,12 +215,12 @@ null :: PathsPrefixTree q f r -> Bool
 null (PathsPrefixTree AnEmptySet s) = all (\(TRM.WrapTypeable (AStep x)) -> all null x) (Exts.toList s)
 null _ = False
 
-foldWith
-  :: forall q f m r.
-  Monoid m
-  => (forall a. Ord (f a) => Paths q r a -> f a -> m)
-  -> PathsPrefixTree q f r
-  -> m
+foldWith ::
+  forall q f m r.
+  Monoid m =>
+  (forall a. Ord (f a) => Paths q r a -> f a -> m) ->
+  PathsPrefixTree q f r ->
+  m
 foldWith k = goTPT Root
   where
     goTPT :: forall a. Paths q r a -> PathsPrefixTree q f a -> m

src/Data/OpenApi/Compare/References.hs

@@ -1,9 +1,9 @@
 {-# OPTIONS_GHC -Wno-orphans #-}
 
 module Data.OpenApi.Compare.References
-  ( Step (..)
-  , dereference
-  , Typeable
+  ( Step (..),
+    dereference,
+    Typeable,
   )
 where
 
@@ -18,11 +18,11 @@ instance Typeable a => Steppable (Referenced a) a where
   data Step (Referenced a) a = InlineStep
     deriving stock (Eq, Ord, Show)
 
-dereference
-  :: Typeable a
-  => Traced (Definitions a)
-  -> Traced (Referenced a)
-  -> Traced a
+dereference ::
+  Typeable a =>
+  Traced (Definitions a) ->
+  Traced (Referenced a) ->
+  Traced a
 dereference defs x = case extract x of
   Inline a ->
     traced (ask x >>> step InlineStep) a

src/Data/OpenApi/Compare/Report.hs

@@ -1,13 +1,13 @@
 module Data.OpenApi.Compare.Report
-  ( generateReport
-  , CheckerOutput(..)
-  , ReportInput (..)
-  , segregateIssues
-  , ReportStatus (..)
-  , Pandoc
-  , ReportConfig (..)
-  , ReportTreeStyle (..)
-  , ReportMode (..)
+  ( generateReport,
+    CheckerOutput (..),
+    ReportInput (..),
+    segregateIssues,
+    ReportStatus (..),
+    Pandoc,
+    ReportConfig (..),
+    ReportTreeStyle (..),
+    ReportMode (..),
   )
 where
 
@@ -30,8 +30,8 @@ import qualified Data.OpenApi.Compare.PathsPrefixTree as P hiding (empty)
 import Data.OpenApi.Compare.Report.Jet
 import Data.OpenApi.Compare.Subtree (invertIssueOrientationP)
 import Data.OpenApi.Compare.Validate.OpenApi
-import Data.OpenApi.Compare.Validate.Schema.TypedJson
 import Data.OpenApi.Compare.Validate.Schema.Issues
+import Data.OpenApi.Compare.Validate.Schema.TypedJson
 import Data.OpenUnion
 import Data.OpenUnion.Extra
 import Data.Set
@@ -54,22 +54,27 @@ data CheckerOutput = CheckerOutput
   deriving anyclass (ToJSON)
 
 data ReportInput = ReportInput
-  { breakingChanges :: Changes -- ^ forward 'CertainIssue', 'ProbablyIssue' and 'Comment'
-  , nonBreakingChanges :: Changes -- ^ backward 'CertainIssue', 'ProbablyIssue' and 'Comment', except those shadowed by 'relatedIssues'
-  , unsupportedChanges :: Changes -- ^ forward and backward 'Unsupported' (assumed to be the same anyway)
-  , schemaIssues :: Changes -- ^ forward and backward 'SchemaInvalid' (assumed to be the same anyway)
+  { -- | forward 'CertainIssue', 'ProbablyIssue' and 'Comment'
+    breakingChanges :: Changes
+  , -- | backward 'CertainIssue', 'ProbablyIssue' and 'Comment', except those shadowed by 'relatedIssues'
+    nonBreakingChanges :: Changes
+  , -- | forward and backward 'Unsupported' (assumed to be the same anyway)
+    unsupportedChanges :: Changes
+  , -- | forward and backward 'SchemaInvalid' (assumed to be the same anyway)
+    schemaIssues :: Changes
   }
   deriving stock (Generic)
   deriving (Semigroup, Monoid) via (Generically ReportInput)
   deriving anyclass (ToJSON)
 
 segregateIssues :: CheckerOutput -> ReportInput
-segregateIssues CheckerOutput {forwardChanges = fwd, backwardChanges = bck} = ReportInput
-  { breakingChanges = P.filter isBreaking fwd
-  , nonBreakingChanges = invertIssueOrientationP $ P.filterWithKey isNonBreaking bck
-  , unsupportedChanges = P.filter isUnsupported fwd <> P.filter isUnsupported bck
-  , schemaIssues = P.filter isSchemaIssue fwd <> P.filter isSchemaIssue bck
-  }
+segregateIssues CheckerOutput {forwardChanges = fwd, backwardChanges = bck} =
+  ReportInput
+    { breakingChanges = P.filter isBreaking fwd
+    , nonBreakingChanges = invertIssueOrientationP $ P.filterWithKey isNonBreaking bck
+    , unsupportedChanges = P.filter isUnsupported fwd <> P.filter isUnsupported bck
+    , schemaIssues = P.filter isSchemaIssue fwd <> P.filter isSchemaIssue bck
+    }
   where
     isBreaking i = anIssueKind i `elem` [CertainIssue, ProbablyIssue, Comment]
     isNonBreaking :: Paths Behave 'APILevel a -> AnIssue a -> Bool
@@ -106,8 +111,7 @@ twoRowTable x = simpleTable (para . fst <$> x) [para . snd <$> x]
 
 generateReport :: ReportConfig -> ReportInput -> (Blocks, ReportStatus)
 generateReport cfg inp =
-  let
-      schemaIssuesPresent = not $ P.null $ schemaIssues inp
+  let schemaIssuesPresent = not $ P.null $ schemaIssues inp
       breakingChangesPresent = not $ P.null $ breakingChanges inp
       nonBreakingChangesPresent = not $ P.null $ nonBreakingChanges inp
       unsupportedChangesPresent = not $ P.null $ unsupportedChanges inp
@@ -116,47 +120,55 @@ generateReport cfg inp =
         OnlyErrors -> False
       builder = buildReport cfg
       report =
-          header 1 "Summary"
-            <> twoRowTable
-              (when'
-                 schemaIssuesPresent
-                 [ ( refOpt schemaIssuesPresent schemaIssuesId "‼️ Schema issues"
-                   , show' $ P.size $ schemaIssues inp
-                   )
-                 ]
-                 ++
-                   [ ( refOpt breakingChangesPresent breakingChangesId "❌ Breaking changes"
+        header 1 "Summary"
+          <> twoRowTable
+            ( when'
+                schemaIssuesPresent
+                [
+                  ( refOpt schemaIssuesPresent schemaIssuesId "‼️ Schema issues"
+                  , show' $ P.size $ schemaIssues inp
+                  )
+                ]
+                ++ [
+                     ( refOpt breakingChangesPresent breakingChangesId "❌ Breaking changes"
                      , show' $ P.size $ breakingChanges inp
                      )
                    ]
-                 ++ when'
-                   nonBreakingChangesShown
-                   [ ( refOpt nonBreakingChangesPresent nonBreakingChangesId "⚠️ Non-breaking changes"
-                     , show' $ P.size $ nonBreakingChanges inp
-                     )
-                   ]
-                 ++ when'
-                   unsupportedChangesPresent
-                   [ ( refOpt unsupportedChangesPresent unsupportedChangesId "❓ Unsupported feature changes"
-                     , show' $ P.size $ unsupportedChanges inp
-                     )
-                   ])
-            <> when'
-              schemaIssuesPresent
-              (header 1 (anchor schemaIssuesId <> "‼️ Schema issues")
-                 <> builder (showErrs $ schemaIssues inp))
-            <> when'
-              breakingChangesPresent
-              (header 1 (anchor breakingChangesId <> "❌ Breaking changes")
-                 <> builder (showErrs $ breakingChanges inp))
-            <> when'
-              (nonBreakingChangesPresent && nonBreakingChangesShown)
-              (header 1 (anchor nonBreakingChangesId <> "⚠️ Non-breaking changes")
-                 <> builder (showErrs $ nonBreakingChanges inp))
-            <> when'
-              unsupportedChangesPresent
-              (header 1 (anchor unsupportedChangesId <> "❓ Unsupported feature changes")
-                 <> builder (showErrs $ unsupportedChanges inp))
+                ++ when'
+                  nonBreakingChangesShown
+                  [
+                    ( refOpt nonBreakingChangesPresent nonBreakingChangesId "⚠️ Non-breaking changes"
+                    , show' $ P.size $ nonBreakingChanges inp
+                    )
+                  ]
+                ++ when'
+                  unsupportedChangesPresent
+                  [
+                    ( refOpt unsupportedChangesPresent unsupportedChangesId "❓ Unsupported feature changes"
+                    , show' $ P.size $ unsupportedChanges inp
+                    )
+                  ]
+            )
+          <> when'
+            schemaIssuesPresent
+            ( header 1 (anchor schemaIssuesId <> "‼️ Schema issues")
+                <> builder (showErrs $ schemaIssues inp)
+            )
+          <> when'
+            breakingChangesPresent
+            ( header 1 (anchor breakingChangesId <> "❌ Breaking changes")
+                <> builder (showErrs $ breakingChanges inp)
+            )
+          <> when'
+            (nonBreakingChangesPresent && nonBreakingChangesShown)
+            ( header 1 (anchor nonBreakingChangesId <> "⚠️ Non-breaking changes")
+                <> builder (showErrs $ nonBreakingChanges inp)
+            )
+          <> when'
+            unsupportedChangesPresent
+            ( header 1 (anchor unsupportedChangesId <> "❓ Unsupported feature changes")
+                <> builder (showErrs $ unsupportedChanges inp)
+            )
       status =
         if
             | breakingChangesPresent -> BreakingChanges
@@ -186,13 +198,14 @@ showErrs x@(P.PathsPrefixNode currentIssues _) =
   let -- Extract this pattern if more cases like this arise
       ( removedPaths :: Maybe (Orientation, [Issue 'APILevel])
         , otherIssues :: Set (AnIssue a)
-        ) = case eqT @a @'APILevel of
+        ) = case eqT @a @ 'APILevel of
           Just Refl
             | (S.toList -> p@((AnIssue ori _) : _), o) <-
                 S.partition
-                  (\((AnIssue _ u)) -> case u of
-                     NoPathsMatched {} -> True
-                     AllPathsFailed {} -> True)
+                  ( \((AnIssue _ u)) -> case u of
+                      NoPathsMatched {} -> True
+                      AllPathsFailed {} -> True
+                  )
                   currentIssues ->
               let p' = p <&> (\(AnIssue _ i) -> i)
                in (Just (ori, p'), o)
@@ -203,9 +216,10 @@ showErrs x@(P.PathsPrefixNode currentIssues _) =
       paths = case removedPaths of
         Just (ori, ps) -> do
           singletonHeader
-            (case ori of
-               Forward -> "Removed paths"
-               Backward -> "Added paths")
+            ( case ori of
+                Forward -> "Removed paths"
+                Backward -> "Added paths"
+            )
             $ singletonBody $
               bulletList $
                 ps <&> \case
@@ -249,52 +263,54 @@ jets =
     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 ::
+      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 ::
+          [ 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 (SingletonUnion (OfType Array) : xs@(SingletonUnion (InItem _) : _)) = showParts xs
         showParts (y : ys) =
-          ((\(OfType t) -> "(" <> describeJSONType t <> ")")
-             @@> (\case
-                    InItems -> "[*]"
-                    InItem i -> "[" <> T.pack (show i) <> "]"
-                    InProperty p -> "." <> p
-                    InAdditionalProperty -> ".*")
-             @@> typesExhausted)
+          ( (\(OfType t) -> "(" <> describeJSONType t <> ")")
+              @@> ( \case
+                      InItems -> "[*]"
+                      InItem i -> "[" <> T.pack (show i) <> "]"
+                      InProperty p -> "." <> p
+                      InAdditionalProperty -> ".*"
+                  )
+              @@> typesExhausted
+          )
             y
             <> showParts ys
 
-observeJetShowErrs
-  :: ReportJet' Behave (Maybe Inlines)
-  -> P.PathsPrefixTree Behave AnIssue a
-  -> (Report, P.PathsPrefixTree Behave AnIssue a)
+observeJetShowErrs ::
+  ReportJet' Behave (Maybe Inlines) ->
+  P.PathsPrefixTree Behave AnIssue a ->
+  (Report, P.PathsPrefixTree Behave AnIssue a)
 observeJetShowErrs jet p = case observeJetShowErrs' jet p of
   Just m -> m
   Nothing -> (mempty, p)
 
-observeJetShowErrs'
-  :: forall a.
-     ReportJet' Behave (Maybe Inlines)
-  -> P.PathsPrefixTree Behave AnIssue a
-  -> Maybe (Report, P.PathsPrefixTree Behave AnIssue a)
+observeJetShowErrs' ::
+  forall a.
+  ReportJet' Behave (Maybe Inlines) ->
+  P.PathsPrefixTree Behave AnIssue a ->
+  Maybe (Report, P.PathsPrefixTree Behave AnIssue a)
 observeJetShowErrs' (ReportJet jet) (P.PathsPrefixNode currentIssues subIssues) =
   let results =
         subIssues >>= \(WrapTypeable (AStep m)) ->
@@ -302,21 +318,23 @@ observeJetShowErrs' (ReportJet jet) (P.PathsPrefixNode currentIssues subIssues)
             maybe (Left $ embed (step bhv) subErrs) Right . listToMaybe $
               jet @_ @_ @[] bhv
                 & mapMaybe
-                  (\case
-                     Free jet' -> fmap (embed $ step bhv) <$> observeJetShowErrs' jet' subErrs
-                     Pure (Just h) ->
-                       if P.null subErrs
-                         then Just mempty
-                         else Just (singletonHeader h (showErrs subErrs), mempty)
-                     Pure Nothing -> Nothing)
+                  ( \case
+                      Free jet' -> fmap (embed $ step bhv) <$> observeJetShowErrs' jet' subErrs
+                      Pure (Just h) ->
+                        if P.null subErrs
+                          then Just mempty
+                          else Just (singletonHeader h (showErrs subErrs), mempty)
+                      Pure Nothing -> Nothing
+                  )
    in (fmap . fmap) (PathsPrefixNode currentIssues mempty <>) $
         if any isRight results
           then
             Just $
               foldMap
-                (\case
-                   Left e -> (mempty, e)
-                   Right m -> m)
+                ( \case
+                    Left e -> (mempty, e)
+                    Right m -> m
+                )
                 results
           else Nothing
 
@@ -339,8 +357,9 @@ buildReport cfg = case treeStyle cfg of
       body rprt
         <> foldOMapWithKey
           (headers rprt)
-          (\k v ->
-             header level k <> subBuilder v)
+          ( \k v ->
+              header level k <> subBuilder v
+          )
       where
         subBuilder = headerStyleBuilder (level + 1)
 
@@ -349,16 +368,17 @@ buildReport cfg = case treeStyle cfg of
       body rprt
         <> foldOMapWithKey
           (headers rprt)
-          (\k v ->
-             if (OM.size . headers $ rprt) < 2
-               then para k <> blockQuote (subBuilder v)
-               else
-                 rawHtml "<details>"
-                   <> rawHtml "<summary>"
-                   <> plain k
-                   <> rawHtml "</summary>"
-                   <> blockQuote (subBuilder v)
-                   <> rawHtml "</details>")
+          ( \k v ->
+              if (OM.size . headers $ rprt) < 2
+                then para k <> blockQuote (subBuilder v)
+                else
+                  rawHtml "<details>"
+                    <> rawHtml "<summary>"
+                    <> plain k
+                    <> rawHtml "</summary>"
+                    <> blockQuote (subBuilder v)
+                    <> rawHtml "</details>"
+          )
       where
         subBuilder = foldingStyleBuilder
 

src/Data/OpenApi/Compare/Report/Html/Template.hs

@@ -1,7 +1,7 @@
 {-# LANGUAGE TemplateHaskell #-}
 
 module Data.OpenApi.Compare.Report.Html.Template
-  ( template
+  ( template,
   )
 where
 

src/Data/OpenApi/Compare/Report/Jet.hs

@@ -1,8 +1,8 @@
 module Data.OpenApi.Compare.Report.Jet
-  ( ReportJet (..)
-  , ReportJet'
-  , ConstructReportJet (..)
-  , ReportJetResult
+  ( ReportJet (..),
+    ReportJet',
+    ConstructReportJet (..),
+    ReportJetResult,
   )
 where
 

src/Data/OpenApi/Compare/Run.hs

@@ -1,17 +1,17 @@
 module Data.OpenApi.Compare.Run
-  ( runChecker
-  , runReport
-  , module Data.OpenApi.Compare.Report
+  ( runChecker,
+    runReport,
+    module Data.OpenApi.Compare.Report,
   )
 where
 
 import Data.HList
 import Data.OpenApi (OpenApi)
-import Text.Pandoc.Builder
 import Data.OpenApi.Compare.Paths
 import Data.OpenApi.Compare.Report
 import Data.OpenApi.Compare.Subtree
 import Data.OpenApi.Compare.Validate.OpenApi ()
+import Text.Pandoc.Builder
 
 runChecker :: (OpenApi, OpenApi) -> CheckerOutput
 runChecker (client, server) =

src/Data/OpenApi/Compare/Subtree.hs

@@ -1,52 +1,52 @@
 {-# OPTIONS_GHC -Wno-orphans #-}
 
 module Data.OpenApi.Compare.Subtree
-  ( Steppable (..)
-  , Step (..)
-  , TraceRoot
-  , Trace
-  , Traced
-  , Traced'
-  , pattern Traced
-  , traced
-  , retraced
-  , stepTraced
-  , Subtree (..)
-  , checkCompatibility
-  , checkSubstructure
-  , CompatM (..)
-  , CompatFormula'
-  , SemanticCompatFormula
-  , ProdCons (..)
-  , orientProdCons
-  , swapProdCons
-  , runCompatFormula
-  , issueAt
-  , anItem
-  , anIssue
-  , invertIssueOrientation
-  , invertIssueOrientationP
-  , embedFormula
-  , anyOfAt
-  , clarifyIssue
-  , structuralIssue
+  ( Steppable (..),
+    Step (..),
+    TraceRoot,
+    Trace,
+    Traced,
+    Traced',
+    pattern Traced,
+    traced,
+    retraced,
+    stepTraced,
+    Subtree (..),
+    checkCompatibility,
+    checkSubstructure,
+    CompatM (..),
+    CompatFormula',
+    SemanticCompatFormula,
+    ProdCons (..),
+    orientProdCons,
+    swapProdCons,
+    runCompatFormula,
+    issueAt,
+    anItem,
+    anIssue,
+    invertIssueOrientation,
+    invertIssueOrientationP,
+    embedFormula,
+    anyOfAt,
+    clarifyIssue,
+    structuralIssue,
 
     -- * Structural helpers
-  , structuralMaybe
-  , structuralMaybeWith
-  , structuralEq
-  , iohmStructural
-  , iohmStructuralWith
-  , structuralList
+    structuralMaybe,
+    structuralMaybeWith,
+    structuralEq,
+    iohmStructural,
+    iohmStructuralWith,
+    structuralList,
 
     -- * Reexports
-  , (>>>)
-  , (<<<)
-  , extract
-  , ask
-  , local
-  , step
-  , Typeable
+    (>>>),
+    (<<<),
+    extract,
+    ask,
+    local,
+    step,
+    Typeable,
   )
 where
 
@@ -115,10 +115,10 @@ orientProdCons :: Orientation -> ProdCons x -> ProdCons x
 orientProdCons Forward x = x
 orientProdCons Backward (ProdCons p c) = ProdCons c p
 
-swapProdCons
-  :: SwapEnvRoles xs
-  => (HList xs -> ProdCons x -> CompatFormula' q AnIssue r a)
-  -> (HList xs -> ProdCons x -> CompatFormula' q AnIssue r a)
+swapProdCons ::
+  SwapEnvRoles xs =>
+  (HList xs -> ProdCons x -> CompatFormula' q AnIssue r a) ->
+  (HList xs -> ProdCons x -> CompatFormula' q AnIssue r a)
 swapProdCons f e (ProdCons p c) =
   invertIssueOrientation $
     f (swapEnvRoles e) (ProdCons c p)
@@ -153,8 +153,8 @@ instance Applicative ProdCons where
   ProdCons fp fc <*> ProdCons xp xc = ProdCons (fp xp) (fc xc)
 
 newtype CompatM a = CompatM
-  { unCompatM
-    :: StateT (MemoState VarRef) Identity a
+  { unCompatM ::
+      StateT (MemoState VarRef) Identity a
   }
   deriving newtype
     ( Functor
@@ -183,64 +183,64 @@ class (Typeable t, Issuable (SubtreeLevel t)) => Subtree (t :: Type) where
   type CheckEnv t :: [Type]
   type SubtreeLevel t :: BehaviorLevel
 
-  checkStructuralCompatibility
-    :: HList (CheckEnv t)
-    -> ProdCons (Traced t)
-    -> StructuralCompatFormula ()
+  checkStructuralCompatibility ::
+    HList (CheckEnv t) ->
+    ProdCons (Traced t) ->
+    StructuralCompatFormula ()
 
-  checkSemanticCompatibility
-    :: HList (CheckEnv t)
-    -> Behavior (SubtreeLevel t)
-    -> ProdCons (Traced t)
-    -> SemanticCompatFormula ()
+  checkSemanticCompatibility ::
+    HList (CheckEnv t) ->
+    Behavior (SubtreeLevel t) ->
+    ProdCons (Traced t) ->
+    SemanticCompatFormula ()
 
 {-# WARNING checkStructuralCompatibility "You should not be calling this directly. Use 'checkSubstructure'" #-}
 
 {-# WARNING checkSemanticCompatibility "You should not be calling this directly. Use 'checkCompatibility'" #-}
 
-checkCompatibility
-  :: forall t xs.
-  (ReassembleHList xs (CheckEnv t), Subtree t)
-  => Behavior (SubtreeLevel t)
-  -> HList xs
-  -> ProdCons (Traced t)
-  -> SemanticCompatFormula ()
+checkCompatibility ::
+  forall t xs.
+  (ReassembleHList xs (CheckEnv t), Subtree t) =>
+  Behavior (SubtreeLevel t) ->
+  HList xs ->
+  ProdCons (Traced t) ->
+  SemanticCompatFormula ()
 checkCompatibility bhv e = memo bhv SemanticMemoKey $ \pc ->
   case runCompatFormula $ checkSubstructure e pc of
     Left _ -> checkSemanticCompatibility (reassemble e) bhv pc
     Right () -> pure ()
 {-# INLINE checkCompatibility #-}
 
-checkSubstructure
-  :: (ReassembleHList xs (CheckEnv t), Subtree t)
-  => HList xs
-  -> ProdCons (Traced t)
-  -> StructuralCompatFormula ()
+checkSubstructure ::
+  (ReassembleHList xs (CheckEnv t), Subtree t) =>
+  HList xs ->
+  ProdCons (Traced t) ->
+  StructuralCompatFormula ()
 checkSubstructure e = memo Root StructuralMemoKey $ checkStructuralCompatibility (reassemble e)
 {-# INLINE checkSubstructure #-}
 
-structuralMaybe
-  :: (Subtree a, ReassembleHList xs (CheckEnv a))
-  => HList xs
-  -> ProdCons (Maybe (Traced a))
-  -> StructuralCompatFormula ()
+structuralMaybe ::
+  (Subtree a, ReassembleHList xs (CheckEnv a)) =>
+  HList xs ->
+  ProdCons (Maybe (Traced a)) ->
+  StructuralCompatFormula ()
 structuralMaybe e = structuralMaybeWith (checkSubstructure e)
 {-# INLINE structuralMaybe #-}
 
-structuralMaybeWith
-  :: (ProdCons a -> StructuralCompatFormula ())
-  -> ProdCons (Maybe a)
-  -> StructuralCompatFormula ()
+structuralMaybeWith ::
+  (ProdCons a -> StructuralCompatFormula ()) ->
+  ProdCons (Maybe a) ->
+  StructuralCompatFormula ()
 structuralMaybeWith f (ProdCons (Just a) (Just b)) = f $ ProdCons a b
 structuralMaybeWith _ (ProdCons Nothing Nothing) = pure ()
 structuralMaybeWith _ _ = structuralIssue
 {-# INLINE structuralMaybeWith #-}
 
-structuralList
-  :: (Subtree a, ReassembleHList xs (CheckEnv a))
-  => HList xs
-  -> ProdCons [Traced a]
-  -> StructuralCompatFormula ()
+structuralList ::
+  (Subtree a, ReassembleHList xs (CheckEnv a)) =>
+  HList xs ->
+  ProdCons [Traced a] ->
+  StructuralCompatFormula ()
 structuralList _ (ProdCons [] []) = pure ()
 structuralList e (ProdCons (a : aa) (b : bb)) = do
   checkSubstructure e $ ProdCons a b
@@ -253,11 +253,11 @@ structuralEq :: (Eq a, Comonad w) => ProdCons (w a) -> StructuralCompatFormula (
 structuralEq (ProdCons a b) = if extract a == extract b then pure () else structuralIssue
 {-# INLINE structuralEq #-}
 
-iohmStructural
-  :: (ReassembleHList (k ': xs) (CheckEnv v), Ord k, Subtree v, Hashable k, Typeable k, Show k)
-  => HList xs
-  -> ProdCons (Traced (IOHM.InsOrdHashMap k v))
-  -> StructuralCompatFormula ()
+iohmStructural ::
+  (ReassembleHList (k ': xs) (CheckEnv v), Ord k, Subtree v, Hashable k, Typeable k, Show k) =>
+  HList xs ->
+  ProdCons (Traced (IOHM.InsOrdHashMap k v)) ->
+  StructuralCompatFormula ()
 iohmStructural e =
   iohmStructuralWith (\k -> checkSubstructure (k `HCons` e))
 {-# INLINE iohmStructural #-}
@@ -266,25 +266,26 @@ instance (Typeable k, Typeable v, Ord k, Show k) => Steppable (IOHM.InsOrdHashMa
   data Step (IOHM.InsOrdHashMap k v) v = InsOrdHashMapKeyStep k
     deriving stock (Eq, Ord, Show)
 
-iohmStructuralWith
-  :: (Ord k, Hashable k, Typeable k, Typeable v, Show k)
-  => (k -> ProdCons (Traced v) -> StructuralCompatFormula ())
-  -> ProdCons (Traced (IOHM.InsOrdHashMap k v))
-  -> StructuralCompatFormula ()
+iohmStructuralWith ::
+  (Ord k, Hashable k, Typeable k, Typeable v, Show k) =>
+  (k -> ProdCons (Traced v) -> StructuralCompatFormula ()) ->
+  ProdCons (Traced (IOHM.InsOrdHashMap k v)) ->
+  StructuralCompatFormula ()
 iohmStructuralWith f pc = do
   let ProdCons pEKeys cEKeys = S.fromList . IOHM.keys . extract <$> pc
   if pEKeys == cEKeys
     then
       for_
         pEKeys
-        (\eKey ->
-           f eKey $ stepTraced (InsOrdHashMapKeyStep eKey) . fmap (IOHM.lookupDefault (error "impossible") eKey) <$> pc)
+        ( \eKey ->
+            f eKey $ stepTraced (InsOrdHashMapKeyStep eKey) . fmap (IOHM.lookupDefault (error "impossible") eKey) <$> pc
+        )
     else structuralIssue
 {-# INLINE iohmStructuralWith #-}
 
-runCompatFormula
-  :: CompatFormula' q f r a
-  -> Either (P.PathsPrefixTree q f r) a
+runCompatFormula ::
+  CompatFormula' q f r a ->
+  Either (P.PathsPrefixTree q f r) a
 runCompatFormula (Compose f) =
   calculate . runIdentity . runMemo 0 . unCompatM $ f
 {-# INLINE runCompatFormula #-}
@@ -314,27 +315,27 @@ invertIssueOrientationP = P.map (\(AnIssue ori i) -> AnIssue (toggleOrientation
 structuralIssue :: StructuralCompatFormula a
 structuralIssue = Compose $ pure $ anError $ AnItem Root Proxy
 
-anyOfAt
-  :: Issuable l
-  => Paths q r l
-  -> Issue l
-  -> [CompatFormula' q AnIssue r a]
-  -> CompatFormula' q AnIssue r a
+anyOfAt ::
+  Issuable l =>
+  Paths q r l ->
+  Issue l ->
+  [CompatFormula' q AnIssue r a] ->
+  CompatFormula' q AnIssue r a
 anyOfAt _ _ [x] = x
 anyOfAt xs issue fs =
   Compose $ (`eitherOf` AnItem xs (anIssue issue)) <$> traverse getCompose fs
 
 -- | If the given formula contains any issues, add another issue on top. Otherwise succeed.
-clarifyIssue
-  :: AnItem q AnIssue r
-  -> CompatFormula' q AnIssue r a
-  -> CompatFormula' q AnIssue r a
+clarifyIssue ::
+  AnItem q AnIssue r ->
+  CompatFormula' q AnIssue r a ->
+  CompatFormula' q AnIssue r a
 clarifyIssue item f =
   Compose ((`eitherOf` item) <$> pure <$> getCompose f) *> f
 
-fixpointKnot
-  :: MonadState (MemoState VarRef) m
-  => KnotTier (FormulaF q f r ()) VarRef m
+fixpointKnot ::
+  MonadState (MemoState VarRef) m =>
+  KnotTier (FormulaF q f r ()) VarRef m
 fixpointKnot =
   KnotTier
     { onKnotFound = modifyMemoNonce succ
@@ -342,19 +343,20 @@ fixpointKnot =
     , tieKnot = \i x -> pure $ maxFixpoint i x
     }
 
-memo
-  :: (Typeable (l :: k), Typeable q, Typeable f, Typeable k, Typeable a)
-  => Paths q r l
-  -> MemoKey
-  -> (ProdCons (Traced a) -> CompatFormula' q f r ())
-  -> (ProdCons (Traced a) -> CompatFormula' q f r ())
+memo ::
+  (Typeable (l :: k), Typeable q, Typeable f, Typeable k, Typeable a) =>
+  Paths q r l ->
+  MemoKey ->
+  (ProdCons (Traced a) -> CompatFormula' q f r ()) ->
+  (ProdCons (Traced a) -> CompatFormula' q f r ())
 memo bhv k f pc = Compose $ do
   formula' <-
     memoWithKnot
       fixpointKnot
-      (do
-         formula <- getCompose $ f pc
-         pure $ mapErrors (P.takeSubtree bhv) formula)
+      ( do
+          formula <- getCompose $ f pc
+          pure $ mapErrors (P.takeSubtree bhv) formula
+      )
       (k, ask <$> pc)
   pure $ mapErrors (P.embed bhv) formula'
 

src/Data/OpenApi/Compare/Validate/MediaTypeObject.hs

@@ -1,8 +1,8 @@
 {-# OPTIONS_GHC -Wno-orphans #-}
 
 module Data.OpenApi.Compare.Validate.MediaTypeObject
-  ( Issue (..)
-  , Behave (..)
+  ( Issue (..),
+    Behave (..),
   )
 where
 

src/Data/OpenApi/Compare/Validate/OAuth2Flows.hs

@@ -1,9 +1,9 @@
 {-# OPTIONS_GHC -Wno-orphans #-}
 
 module Data.OpenApi.Compare.Validate.OAuth2Flows
-  ( Step (..)
-  , Issue (..)
-  , Behave (..)
+  ( Step (..),
+    Issue (..),
+    Behave (..),
   )
 where
 
@@ -26,11 +26,11 @@ instance Subtree OAuth2Flows where
   type SubtreeLevel OAuth2Flows = 'SecuritySchemeLevel
   checkStructuralCompatibility _ = structuralEq
   checkSemanticCompatibility env bhv pc = do
-    let supportFlow
-          :: (Subtree t, SubtreeLevel t ~ SubtreeLevel OAuth2Flows, CheckEnv OAuth2Flows ~ CheckEnv t)
-          => Issue 'SecuritySchemeLevel
-          -> ProdCons (Maybe (Traced t))
-          -> SemanticCompatFormula ()
+    let supportFlow ::
+          (Subtree t, SubtreeLevel t ~ SubtreeLevel OAuth2Flows, CheckEnv OAuth2Flows ~ CheckEnv t) =>
+          Issue 'SecuritySchemeLevel ->
+          ProdCons (Maybe (Traced t)) ->
+          SemanticCompatFormula ()
         supportFlow i x = case x of
           -- producer will not attempt this flow
           (ProdCons Nothing _) -> pure ()
@@ -38,11 +38,11 @@ instance Subtree OAuth2Flows where
           (ProdCons (Just _) Nothing) -> issueAt bhv i
           (ProdCons (Just p) (Just c)) ->
             checkCompatibility bhv env $ ProdCons p c
-        getFlow
-          :: Typeable x
-          => (OAuth2Flows -> Maybe (OAuth2Flow x))
-          -> Traced OAuth2Flows
-          -> Maybe (Traced (OAuth2Flow x))
+        getFlow ::
+          Typeable x =>
+          (OAuth2Flows -> Maybe (OAuth2Flow x)) ->
+          Traced OAuth2Flows ->
+          Maybe (Traced (OAuth2Flow x))
         getFlow f (Traced t a) = Traced (t >>> step (OAuth2FlowsFlow Proxy)) <$> f a
     supportFlow ConsumerDoesNotSupportImplicitFlow $ getFlow _oAuth2FlowsImplicit <$> pc
     supportFlow ConsumerDoesNotSupportPasswordFlow $ getFlow _oAuth2FlowsPassword <$> pc

src/Data/OpenApi/Compare/Validate/OpenApi.hs

@@ -3,8 +3,8 @@
 {-# OPTIONS_GHC -fconstraint-solver-iterations=0 #-}
 
 module Data.OpenApi.Compare.Validate.OpenApi
-  ( Behave (..)
-  , Issue (..)
+  ( Behave (..),
+    Issue (..),
   )
 where
 
@@ -79,16 +79,17 @@ instance Subtree OpenApi where
   checkSemanticCompatibility _ beh prodCons = do
     checkCompatibility @ProcessedPathItems
       beh
-      ((tracedRequestBodies <$> prodCons)
-         `HCons` (tracedParameters <$> prodCons)
-         `HCons` (tracedSecuritySchemes <$> prodCons)
-         `HCons` (tracedResponses <$> prodCons)
-         `HCons` (tracedHeaders <$> prodCons)
-         `HCons` (tracedSchemas <$> prodCons)
-         `HCons` (_openApiServers . extract <$> prodCons)
-         `HCons` (tracedLinks <$> prodCons)
-         `HCons` (tracedCallbacks <$> prodCons)
-         `HCons` HNil)
+      ( (tracedRequestBodies <$> prodCons)
+          `HCons` (tracedParameters <$> prodCons)
+          `HCons` (tracedSecuritySchemes <$> prodCons)
+          `HCons` (tracedResponses <$> prodCons)
+          `HCons` (tracedHeaders <$> prodCons)
+          `HCons` (tracedSchemas <$> prodCons)
+          `HCons` (_openApiServers . extract <$> prodCons)
+          `HCons` (tracedLinks <$> prodCons)
+          `HCons` (tracedCallbacks <$> prodCons)
+          `HCons` HNil
+      )
       (tracedPaths <$> prodCons)
 
 instance Steppable OpenApi ProcessedPathItems where

src/Data/OpenApi/Compare/Validate/Operation.hs

@@ -4,17 +4,17 @@
 
 module Data.OpenApi.Compare.Validate.Operation
   ( -- * Operation
-    MatchedOperation (..)
-  , OperationMethod (..)
-  , pathItemMethod
+    MatchedOperation (..),
+    OperationMethod (..),
+    pathItemMethod,
 
     -- * ProcessedPathItem
-  , ProcessedPathItem (..)
-  , ProcessedPathItems (..)
-  , processPathItems
-  , Step (..)
-  , Behave (..)
-  , Issue (..)
+    ProcessedPathItem (..),
+    ProcessedPathItems (..),
+    processPathItems,
+    Step (..),
+    Behave (..),
+    Issue (..),
   )
 where
 
@@ -87,10 +87,11 @@ tracedCallbacks (Traced t oper) =
   ]
 
 -- FIXME: #28
-getServers
-  :: [Server] -- ^ Servers from env
-  -> MatchedOperation
-  -> [Server]
+getServers ::
+  -- | Servers from env
+  [Server] ->
+  MatchedOperation ->
+  [Server]
 getServers env oper =
   case _operationServers . operation $ oper of
     [] -> env
@@ -337,9 +338,10 @@ instance Issuable 'APILevel where
     deriving stock (Eq, Ord, Show)
   issueKind = \case
     _ -> CertainIssue
-  relatedIssues = (==) `withClass` \case
-    NoPathsMatched fp -> Just fp
-    AllPathsFailed fp -> Just fp
+  relatedIssues =
+    (==) `withClass` \case
+      NoPathsMatched fp -> Just fp
+      AllPathsFailed fp -> Just fp
   describeIssue Forward (NoPathsMatched p) = para $ "The path " <> (code . T.pack) p <> " has been removed."
   describeIssue Backward (NoPathsMatched p) = para $ "The path " <> (code . T.pack) p <> " has been added."
   describeIssue Forward (AllPathsFailed p) = para $ "The path " <> (code . T.pack) p <> " has been removed."
@@ -434,10 +436,10 @@ tracedFragments mpi =
   | (i, x) <- L.zip [0 ..] $ pathFragments $ extract mpi
   ]
 
-tracedMethod
-  :: OperationMethod
-  -> Traced MatchedPathItem
-  -> Maybe (Traced' MatchedOperation Operation)
+tracedMethod ::
+  OperationMethod ->
+  Traced MatchedPathItem ->
+  Maybe (Traced' MatchedOperation Operation)
 tracedMethod s mpi = env (ask mpi >>> step (OperationMethodStep s)) <$> (pathItemMethod s . pathItem . extract $ mpi)
 
 instance Issuable 'PathLevel where
@@ -485,10 +487,10 @@ instance Subtree MatchedPathItem where
   checkSemanticCompatibility env beh prodCons = do
     let paramDefs = getH @(ProdCons (Traced (Definitions Param))) env
         pathTracedParams = getPathParams <$> paramDefs <*> prodCons
-        getPathParams
-          :: Traced (Definitions Param)
-          -> Traced MatchedPathItem
-          -> [Traced Param]
+        getPathParams ::
+          Traced (Definitions Param) ->
+          Traced MatchedPathItem ->
+          [Traced Param]
         getPathParams defs mpi = do
           paramRef <- tracedMatchedPathItemParameters mpi
           pure $ dereference defs paramRef

src/Data/OpenApi/Compare/Validate/Param.hs

@@ -2,8 +2,8 @@
 {-# OPTIONS_GHC -fno-warn-name-shadowing #-}
 
 module Data.OpenApi.Compare.Validate.Param
-  ( Behave (..)
-  , Issue (..)
+  ( Behave (..),
+    Issue (..),
   )
 where
 
@@ -79,7 +79,7 @@ instance Issuable 'PathFragmentLevel where
   describeIssue _ ParamPlaceIncompatible = para "Parameters in incompatible locations."
   describeIssue _ ParamStyleMismatch = para "Different parameter styles (encodings)."
   describeIssue _ ParamSchemaMismatch = para "Expected a schema, but didn't find one."
-  describeIssue ori (PathFragmentsDontMatch (orientProdCons ori -> ProdCons e a)) = 
+  describeIssue ori (PathFragmentsDontMatch (orientProdCons ori -> ProdCons e a)) =
     para $ "Parameter changed from " <> code e <> " to " <> code a <> "."
 
 instance Behavable 'PathFragmentLevel 'SchemaLevel where
@@ -106,15 +106,17 @@ instance Subtree Param where
     when (_paramName (extract p) /= _paramName (extract c)) $
       issueAt beh ParamNameMismatch
     when
-      ((fromMaybe False . _paramRequired . extract $ c)
-         && not (fromMaybe False . _paramRequired . extract $ p))
+      ( (fromMaybe False . _paramRequired . extract $ c)
+          && not (fromMaybe False . _paramRequired . extract $ p)
+      )
       $ issueAt beh ParamRequired
     case (_paramIn . extract $ p, _paramIn . extract $ c) of
       (ParamQuery, ParamQuery) -> do
         -- Emptiness is only for query params
         when
-          ((fromMaybe False . _paramAllowEmptyValue . extract $ p)
-             && not (fromMaybe False . _paramAllowEmptyValue . extract $ c))
+          ( (fromMaybe False . _paramAllowEmptyValue . extract $ p)
+              && not (fromMaybe False . _paramAllowEmptyValue . extract $ c)
+          )
           $ issueAt beh ParamEmptinessIncompatible
       (a, b) | a == b -> pure ()
       _ -> issueAt beh ParamPlaceIncompatible

src/Data/OpenApi/Compare/Validate/PathFragment.hs

@@ -1,7 +1,7 @@
 module Data.OpenApi.Compare.Validate.PathFragment
-  ( parsePath
-  , PathFragment (..)
-  , PathFragmentParam
+  ( parsePath,
+    PathFragment (..),
+    PathFragmentParam,
   )
 where
 

src/Data/OpenApi/Compare/Validate/Products.hs

@@ -1,21 +1,21 @@
-{- | Checks product-like entities. The key is some identificator for the product
-element. Each element may be required or optional.
-
-One example of product is request parameters. There are optional and required
-parameters. The client and server have possibly different set of
-parameters. What we must check is if server requires some request parameter,
-then this parameter must be presented by client and their schemas must match.
-
-So when we checking products we are checking from the server's (consumer)
-perspective, ensuring that all parameters are provided by the client (producer)
-and their schemas match.
-
-This module abstracts this logic for arbitrary elements -}
-
+-- | Checks product-like entities. The key is some identificator for the product
+--element. Each element may be required or optional.
+--
+--One example of product is request parameters. There are optional and required
+--parameters. The client and server have possibly different set of
+--parameters. What we must check is if server requires some request parameter,
+--then this parameter must be presented by client and their schemas must match.
+--
+--So when we checking products we are checking from the server's (consumer)
+--perspective, ensuring that all parameters are provided by the client (producer)
+--and their schemas match.
+--
+--This module abstracts this logic for arbitrary elements
 module Data.OpenApi.Compare.Validate.Products
-  ( checkProducts
-  , ProductLike(..)
-  ) where
+  ( checkProducts,
+    ProductLike (..),
+  )
+where
 
 import Data.Foldable
 import Data.Map.Strict (Map)
@@ -30,20 +30,19 @@ data ProductLike a = ProductLike
   , required :: Bool
   }
 
-checkProducts
-  :: (Ord k, Issuable l)
-  => Paths q r l
-  -> (k -> Issue l)
-  -- ^ No required element found
-  -> (k -> ProdCons t -> CompatFormula' q AnIssue r ())
-  -> ProdCons (Map k (ProductLike t))
-  -> CompatFormula' q AnIssue r ()
+checkProducts ::
+  (Ord k, Issuable l) =>
+  Paths q r l ->
+  -- | No required element found
+  (k -> Issue l) ->
+  (k -> ProdCons t -> CompatFormula' q AnIssue r ()) ->
+  ProdCons (Map k (ProductLike t)) ->
+  CompatFormula' q AnIssue r ()
 checkProducts xs noElt check (ProdCons p c) = for_ (M.toList c) $ \(key, consElt) ->
   case M.lookup key p of
     Nothing -> case required consElt of
-      True  -> issueAt xs $ noElt key
+      True -> issueAt xs $ noElt key
       False -> pure ()
     Just prodElt -> do
-      let
-        elts = ProdCons prodElt consElt
+      let elts = ProdCons prodElt consElt
       check key (productValue <$> elts)

src/Data/OpenApi/Compare/Validate/RequestBody.hs

@@ -1,8 +1,8 @@
 {-# OPTIONS_GHC -Wno-orphans #-}
 
 module Data.OpenApi.Compare.Validate.RequestBody
-  ( Issue (..)
-  , Behave (..)
+  ( Issue (..),
+    Behave (..),
   )
 where
 

src/Data/OpenApi/Compare/Validate/Responses.hs

@@ -2,7 +2,7 @@
 {-# OPTIONS_GHC -fno-warn-name-shadowing #-}
 
 module Data.OpenApi.Compare.Validate.Responses
-  ( Behave (..)
+  ( Behave (..),
   )
 where
 

src/Data/OpenApi/Compare/Validate/Schema.hs

@@ -1,4 +1,5 @@
 {-# OPTIONS_GHC -Wno-orphans #-}
+
 module Data.OpenApi.Compare.Validate.Schema
   (
   )
@@ -10,9 +11,9 @@ import Data.Coerce
 import Data.Foldable (for_, toList)
 import Data.Functor
 import Data.HList
+import Data.List (genericIndex, genericLength, group)
 import qualified Data.List.NonEmpty as NE
 import qualified Data.Map as M
-import Data.List (group, genericLength, genericIndex)
 import Data.Maybe
 import Data.OpenApi
 import Data.OpenApi.Compare.Behavior
@@ -22,24 +23,24 @@ import Data.OpenApi.Compare.Subtree
 import Data.OpenApi.Compare.Validate.Schema.DNF
 import Data.OpenApi.Compare.Validate.Schema.Issues
 import Data.OpenApi.Compare.Validate.Schema.JsonFormula
-import Data.OpenApi.Compare.Validate.Schema.Traced
-import Data.OpenApi.Compare.Validate.Schema.TypedJson
 import Data.OpenApi.Compare.Validate.Schema.Partition
 import Data.OpenApi.Compare.Validate.Schema.Process
+import Data.OpenApi.Compare.Validate.Schema.Traced
+import Data.OpenApi.Compare.Validate.Schema.TypedJson
 import Data.Ord
 import Data.Ratio
 import Data.Semigroup
 import qualified Data.Set as S
 import Data.Text (Text)
 
-checkFormulas
-  :: (ReassembleHList xs (CheckEnv (Referenced Schema)))
-  => HList xs
-  -> Behavior 'SchemaLevel
-  -> ProdCons (Trace Schema)
-  -> ProdCons (Traced (Definitions Schema))
-  -> ProdCons (ForeachType JsonFormula, P.PathsPrefixTree Behave AnIssue 'SchemaLevel)
-  -> SemanticCompatFormula ()
+checkFormulas ::
+  (ReassembleHList xs (CheckEnv (Referenced Schema))) =>
+  HList xs ->
+  Behavior 'SchemaLevel ->
+  ProdCons (Trace Schema) ->
+  ProdCons (Traced (Definitions Schema)) ->
+  ProdCons (ForeachType JsonFormula, P.PathsPrefixTree Behave AnIssue 'SchemaLevel) ->
+  SemanticCompatFormula ()
 checkFormulas env beh trs defs (ProdCons (fp, ep) (fc, ec)) =
   case P.toList ep ++ P.toList ec of
     issues@(_ : _) -> for_ issues $ embedFormula beh . anItem
@@ -144,21 +145,21 @@ checkFormulas env beh trs defs (ProdCons (fp, ep) (fc, ec)) =
         EnumDoesntSatisfy $ untypeValue e -- what does this look like when partitioned?
     issueFromDisjunct mPart ps = NoMatchingCondition mPart $ SomeCondition <$> S.toList ps
 
-checkContradiction
-  :: Behavior 'TypedSchemaLevel
-  -> Maybe Partition
-  -> S.Set (Condition t)
-  -> SemanticCompatFormula ()
+checkContradiction ::
+  Behavior 'TypedSchemaLevel ->
+  Maybe Partition ->
+  S.Set (Condition t) ->
+  SemanticCompatFormula ()
 checkContradiction beh mPart _ = issueAt beh $ maybe TypeBecomesEmpty PartitionBecomesEmpty mPart -- TODO #70
 
-checkImplication
-  :: (ReassembleHList xs (CheckEnv (Referenced Schema)))
-  => HList xs
-  -> Behavior 'TypedSchemaLevel
-  -> ProdCons (Trace Schema) -- the traces of the root schemas used in this comparison
-  -> S.Set (Condition t)
-  -> Condition t
-  -> SemanticCompatFormula ()
+checkImplication ::
+  (ReassembleHList xs (CheckEnv (Referenced Schema))) =>
+  HList xs ->
+  Behavior 'TypedSchemaLevel ->
+  ProdCons (Trace Schema) -> -- the traces of the root schemas used in this comparison
+  S.Set (Condition t) ->
+  Condition t ->
+  SemanticCompatFormula ()
 checkImplication env beh trs prods cons = case findExactly prods of
   Just e
     | all (satisfiesTyped e) prods ->
@@ -166,124 +167,104 @@ checkImplication env beh trs prods cons = case findExactly prods of
         then pure ()
         else issueAt beh (EnumDoesntSatisfy $ untypeValue e)
     | otherwise -> pure () -- vacuously true
-
   Nothing -> case cons of
     -- the above code didn't catch it, so there's no Exactly condition on the lhs
     Exactly e -> issueAt beh (NoMatchingEnum $ untypeValue e)
-
     Maximum m -> foldCheck min m NoMatchingMaximum MatchingMaximumWeak $ \case
       Maximum m' -> Just m'
       _ -> Nothing
-
     Minimum m -> foldCheck max m (NoMatchingMinimum . coerce) (MatchingMinimumWeak . coerce) $ \case
       Minimum m' -> Just m'
       _ -> Nothing
-
     MultipleOf m -> foldCheck lcmScientific m NoMatchingMultipleOf MatchingMultipleOfWeak $ \case
       MultipleOf m' -> Just m'
       _ -> Nothing
-
     NumberFormat f -> case flip any prods $ \case
-          NumberFormat f' -> f == f'
-          _ -> False
-        of
+      NumberFormat f' -> f == f'
+      _ -> False of
       True -> pure ()
       False -> issueAt beh (NoMatchingFormat f)
-
     MaxLength m -> foldCheck min m NoMatchingMaxLength MatchingMaxLengthWeak $ \case
       MaxLength m' -> Just m'
       _ -> Nothing
-
     MinLength m -> foldCheck max m NoMatchingMinLength MatchingMinLengthWeak $ \case
       MinLength m' -> Just m'
       _ -> Nothing
-
     Pattern p -> case flip any prods $ \case
-          Pattern p' -> p == p'
-          _ -> False
-        of
+      Pattern p' -> p == p'
+      _ -> False of
       True -> pure ()
       False -> issueAt beh (NoMatchingPattern p) -- TODO: regex comparison #32
-
     StringFormat f -> case flip any prods $ \case
-          StringFormat f' -> f == f'
-          _ -> False
-        of
+      StringFormat f' -> f == f'
+      _ -> False of
       True -> pure ()
       False -> issueAt beh (NoMatchingFormat f)
-
     Items _ cons' -> case foldSome (<>) prods $ \case
-          Items _ rs -> Just (Just (rs NE.:| []), mempty)
-          TupleItems (map snd -> fs) -> Just (mempty, Just (fs NE.:| []))
-          _ -> Nothing
-        of
+      Items _ rs -> Just (Just (rs NE.:| []), mempty)
+      TupleItems (map snd -> fs) -> Just (mempty, Just (fs NE.:| []))
+      _ -> Nothing of
       Just (mItems, Just pfs)
         | not $ allSame (length <$> pfs) -> pure () -- vacuously
-        | let plen = genericLength (NE.head pfs)
-        -> clarifyIssue (AnItem beh (anIssue TupleToArray)) $ for_ [0 .. plen - 1] $ \i -> do
-            let prod' = tracedConjunct $ case mItems of
-                  Just prods' -> ((`genericIndex` i) <$> pfs) <> prods'
-                  Nothing -> (`genericIndex` i) <$> pfs
-            checkCompatibility (beh >>> step (InItem i)) env $ ProdCons prod' cons'
+        | let plen = genericLength (NE.head pfs) ->
+          clarifyIssue (AnItem beh (anIssue TupleToArray)) $
+            for_ [0 .. plen - 1] $ \i -> do
+              let prod' = tracedConjunct $ case mItems of
+                    Just prods' -> ((`genericIndex` i) <$> pfs) <> prods'
+                    Nothing -> (`genericIndex` i) <$> pfs
+              checkCompatibility (beh >>> step (InItem i)) env $ ProdCons prod' cons'
       Just (Just prods', Nothing) -> do
         let prod' = tracedConjunct prods'
         checkCompatibility (beh >>> step InItems) env $ ProdCons prod' cons'
       _ -> clarifyIssue (AnItem beh (anIssue NoMatchingItems)) $ do
         checkCompatibility (beh >>> step InItems) env $ ProdCons prodTopSchema cons'
-
     TupleItems (map snd -> fs) -> case foldSome (<>) prods $ \case
-        TupleItems (map snd -> fs') -> Just (Just $ fs' NE.:| [], Just . Max $ genericLength fs', Just . Min $ genericLength fs', mempty)
-        MinItems m' -> Just (mempty, Just . Max $ m', mempty, mempty)
-        MaxItems m' -> Just (mempty, mempty, Just . Min $ m', mempty)
-        Items _ rs -> Just (mempty, mempty, mempty, Just (rs NE.:| []))
-        _ -> Nothing
-      of
-        -- if the length constraints in the producer are contradictory:
-        Just (_, Just (Max lowest), Just (Min highest), _) | lowest > highest -> pure ()
-        -- We have an explicit tuple items clause...
-        Just (Just pfs, Just (Max plen), _, _)
-          | plen /= genericLength fs -- ...of wrong length
-          -> issueAt beh (TupleItemsLengthChanged ProdCons {producer = plen, consumer = genericLength fs})
-          | otherwise
-          -> for_ [0 .. plen - 1] $ \i -> do
+      TupleItems (map snd -> fs') -> Just (Just $ fs' NE.:| [], Just . Max $ genericLength fs', Just . Min $ genericLength fs', mempty)
+      MinItems m' -> Just (mempty, Just . Max $ m', mempty, mempty)
+      MaxItems m' -> Just (mempty, mempty, Just . Min $ m', mempty)
+      Items _ rs -> Just (mempty, mempty, mempty, Just (rs NE.:| []))
+      _ -> Nothing of
+      -- if the length constraints in the producer are contradictory:
+      Just (_, Just (Max lowest), Just (Min highest), _) | lowest > highest -> pure ()
+      -- We have an explicit tuple items clause...
+      Just (Just pfs, Just (Max plen), _, _)
+        | plen /= genericLength fs -> -- ...of wrong length
+          issueAt beh (TupleItemsLengthChanged ProdCons {producer = plen, consumer = genericLength fs})
+        | otherwise ->
+          for_ [0 .. plen - 1] $ \i -> do
             checkCompatibility (beh >>> step (InItem i)) env $ ProdCons (tracedConjunct $ (`genericIndex` i) <$> pfs) (fs `genericIndex` i)
-        -- We have a fixed length array in the producer...
-        Just (Nothing, Just (Max plen), Just (Min plen'), mProd)
-          | plen == plen'
-          -> clarifyIssue (AnItem beh (anIssue ArrayToTuple)) $ case mProd of
-            _ | plen /= genericLength fs -> -- ...of wrong length
-              issueAt beh (TupleItemsLengthChanged ProdCons {producer = plen, consumer = genericLength fs})
+      -- We have a fixed length array in the producer...
+      Just (Nothing, Just (Max plen), Just (Min plen'), mProd)
+        | plen == plen' ->
+          clarifyIssue (AnItem beh (anIssue ArrayToTuple)) $ case mProd of
+            _
+              | plen /= genericLength fs -> -- ...of wrong length
+                issueAt beh (TupleItemsLengthChanged ProdCons {producer = plen, consumer = genericLength fs})
             Just rs -> for_ [0 .. plen - 1] $ \i -> do
               checkCompatibility (beh >>> step (InItem i)) env $ ProdCons (tracedConjunct rs) (fs `genericIndex` i)
             -- ...and no "items" schema
             Nothing -> clarifyIssue (AnItem beh (anIssue NoMatchingTupleItems)) $ do
               for_ [0 .. plen - 1] $ \i -> do
                 checkCompatibility (beh >>> step (InItem i)) env $ ProdCons prodTopSchema (fs `genericIndex` i)
-        _ -> issueAt beh NoMatchingTupleItems
-
+      _ -> issueAt beh NoMatchingTupleItems
     MaxItems m -> foldCheck min m NoMatchingMaxItems MatchingMaxItemsWeak $ \case
       MaxItems m' -> Just m'
       TupleItems fs -> Just $ toInteger $ length fs
       _ -> Nothing
-
     MinItems m -> foldCheck max m NoMatchingMinItems MatchingMinItemsWeak $ \case
       MinItems m' -> Just m'
       TupleItems fs -> Just $ toInteger $ length fs
       _ -> Nothing
-
     UniqueItems -> case flip any prods $ \case
-          UniqueItems -> True
-          MaxItems 1 -> True
-          TupleItems fs | length fs == 1 -> True
-          _ -> False
-        of
+      UniqueItems -> True
+      MaxItems 1 -> True
+      TupleItems fs | length fs == 1 -> True
+      _ -> False of
       True -> pure ()
       False -> issueAt beh NoMatchingUniqueItems
-
     Properties props _ madd -> case foldSome (<>) prods $ \case
-          Properties props' _ madd' -> Just $ (props', madd') NE.:| []
-          _ -> Nothing
-        of
+      Properties props' _ madd' -> Just $ (props', madd') NE.:| []
+      _ -> Nothing of
       Just pm ->
         anyOfAt beh NoMatchingProperties $ -- TODO: could first "concat" the lists
           NE.toList pm <&> \(props', madd') -> do
@@ -314,11 +295,9 @@ checkImplication env beh trs prods cons = case findExactly prods of
               (Just add', Just add) -> checkCompatibility (beh >>> step InAdditionalProperty) env (ProdCons add' add)
             pure ()
       Nothing -> issueAt beh NoMatchingProperties
-
     MaxProperties m -> foldCheck min m NoMatchingMaxProperties MatchingMaxPropertiesWeak $ \case
       MaxProperties m' -> Just m'
       _ -> Nothing
-
     MinProperties m -> foldCheck max m NoMatchingMinProperties MatchingMinPropertiesWeak $ \case
       MinProperties m' -> Just m'
       _ -> Nothing
@@ -326,14 +305,14 @@ checkImplication env beh trs prods cons = case findExactly prods of
     lcmScientific (toRational -> a) (toRational -> b) =
       fromRational $ lcm (numerator a) (numerator b) % gcd (denominator a) (denominator b)
 
-    foldCheck
-      :: Eq a
-      => (a -> a -> a)
-      -> a
-      -> (a -> Issue 'TypedSchemaLevel)
-      -> (ProdCons a -> Issue 'TypedSchemaLevel)
-      -> (forall t. Condition t -> Maybe a)
-      -> SemanticCompatFormula ()
+    foldCheck ::
+      Eq a =>
+      (a -> a -> a) ->
+      a ->
+      (a -> Issue 'TypedSchemaLevel) ->
+      (ProdCons a -> Issue 'TypedSchemaLevel) ->
+      (forall t. Condition t -> Maybe a) ->
+      SemanticCompatFormula ()
     foldCheck f m missing weak extr = case foldSome f prods extr of
       Just m'
         | f m' m == m' -> pure ()

src/Data/OpenApi/Compare/Validate/Schema/DNF.hs

@@ -1,12 +1,12 @@
 module Data.OpenApi.Compare.Validate.Schema.DNF
-  ( DNF (..)
-  , Disjunct (..)
-  , pattern SingleDisjunct
-  , pattern TopDNF
-  , pattern BottomDNF
-  , pattern LiteralDNF
-  , foldDNF
-  , forDNF
+  ( DNF (..),
+    Disjunct (..),
+    pattern SingleDisjunct,
+    pattern TopDNF,
+    pattern BottomDNF,
+    pattern LiteralDNF,
+    foldDNF,
+    forDNF,
   )
 where
 

src/Data/OpenApi/Compare/Validate/Schema/Issues.hs

@@ -1,8 +1,8 @@
 {-# OPTIONS_GHC -Wno-orphans #-}
 
 module Data.OpenApi.Compare.Validate.Schema.Issues
-  ( Issue (..)
-  , Behave (..)
+  ( Issue (..),
+    Behave (..),
   )
 where
 
@@ -100,53 +100,54 @@ instance Issuable 'TypedSchemaLevel where
     TypeBecomesEmpty -> ProbablyIssue -- TODO: #70
     PartitionBecomesEmpty _ -> ProbablyIssue -- ditto
     _ -> CertainIssue
-  relatedIssues = (==) `withClass` \case
+  relatedIssues =
+    (==) `withClass` \case
       EnumDoesntSatisfy v -> Just v
       NoMatchingEnum v -> Just v
       _ -> Nothing
-    `withClass` \case
-      NoMatchingMaximum _ -> Just ()
-      MatchingMaximumWeak _ -> Just ()
-      _ -> Nothing
-    `withClass` \case
-      NoMatchingMinimum _ -> Just ()
-      MatchingMinimumWeak _ -> Just ()
-      _ -> Nothing
-    `withClass` \case
-      NoMatchingMultipleOf _ -> Just ()
-      MatchingMultipleOfWeak _ -> Just ()
-      _ -> Nothing
-    `withClass` \case
-      NoMatchingMaxLength _ -> Just ()
-      MatchingMaxLengthWeak _ -> Just ()
-      _ -> Nothing
-    `withClass` \case
-      NoMatchingMinLength _ -> Just ()
-      MatchingMinLengthWeak _ -> Just ()
-      _ -> Nothing
-    `withClass` \case
-      NoMatchingItems -> Just ()
-      ArrayToTuple -> Just ()
-      TupleToArray -> Just ()
-      NoMatchingTupleItems -> Just ()
-      TupleItemsLengthChanged _ -> Just ()
-      _ -> Nothing
-    `withClass` \case
-      NoMatchingMaxItems _ -> Just ()
-      MatchingMaxItemsWeak _ -> Just ()
-      _ -> Nothing
-    `withClass` \case
-      NoMatchingMinItems _ -> Just ()
-      MatchingMinItemsWeak _ -> Just ()
-      _ -> Nothing
-    `withClass` \case
-      NoMatchingMaxProperties _ -> Just ()
-      MatchingMaxPropertiesWeak _ -> Just ()
-      _ -> Nothing
-    `withClass` \case
-      NoMatchingMinProperties _ -> Just ()
-      MatchingMinPropertiesWeak _ -> Just ()
-      _ -> Nothing
+      `withClass` \case
+        NoMatchingMaximum _ -> Just ()
+        MatchingMaximumWeak _ -> Just ()
+        _ -> Nothing
+      `withClass` \case
+        NoMatchingMinimum _ -> Just ()
+        MatchingMinimumWeak _ -> Just ()
+        _ -> Nothing
+      `withClass` \case
+        NoMatchingMultipleOf _ -> Just ()
+        MatchingMultipleOfWeak _ -> Just ()
+        _ -> Nothing
+      `withClass` \case
+        NoMatchingMaxLength _ -> Just ()
+        MatchingMaxLengthWeak _ -> Just ()
+        _ -> Nothing
+      `withClass` \case
+        NoMatchingMinLength _ -> Just ()
+        MatchingMinLengthWeak _ -> Just ()
+        _ -> Nothing
+      `withClass` \case
+        NoMatchingItems -> Just ()
+        ArrayToTuple -> Just ()
+        TupleToArray -> Just ()
+        NoMatchingTupleItems -> Just ()
+        TupleItemsLengthChanged _ -> Just ()
+        _ -> Nothing
+      `withClass` \case
+        NoMatchingMaxItems _ -> Just ()
+        MatchingMaxItemsWeak _ -> Just ()
+        _ -> Nothing
+      `withClass` \case
+        NoMatchingMinItems _ -> Just ()
+        MatchingMinItemsWeak _ -> Just ()
+        _ -> Nothing
+      `withClass` \case
+        NoMatchingMaxProperties _ -> Just ()
+        MatchingMaxPropertiesWeak _ -> Just ()
+        _ -> Nothing
+      `withClass` \case
+        NoMatchingMinProperties _ -> Just ()
+        MatchingMinPropertiesWeak _ -> Just ()
+        _ -> Nothing
   describeIssue Forward (EnumDoesntSatisfy v) = para "The following enum value was removed:" <> showJSONValue v
   describeIssue Backward (EnumDoesntSatisfy v) = para "The following enum value was added:" <> showJSONValue v
   describeIssue Forward (NoMatchingEnum v) = para "The following enum value has been added:" <> showJSONValue v
@@ -254,14 +255,15 @@ instance Issuable 'SchemaLevel where
     PropertyToAdditional -> Comment
     TypesRestricted _ -> ProbablyIssue -- TODO: #70
     _ -> CertainIssue
-  relatedIssues = (==) `withClass` \case
+  relatedIssues =
+    (==) `withClass` \case
       AdditionalToProperty -> Just ()
       PropertyToAdditional -> Just ()
       _ -> Nothing
-    `withClass` \case
-      PropertyNowRequired -> Just ()
-      UnexpectedProperty -> Just ()
-      _ -> Nothing
+      `withClass` \case
+        PropertyNowRequired -> Just ()
+        UnexpectedProperty -> Just ()
+        _ -> Nothing
   describeIssue _ (NotSupported i) =
     para (emph "Encountered a feature that CompaREST does not support: " <> text i <> ".")
   describeIssue _ OneOfNotDisjoint =

src/Data/OpenApi/Compare/Validate/Schema/JsonFormula.hs

@@ -1,18 +1,18 @@
 module Data.OpenApi.Compare.Validate.Schema.JsonFormula
-  ( Bound (..)
-  , showBound
-  , Property (..)
-  , Condition (..)
-  , showCondition
-  , satisfiesTyped
-  , checkStringFormat
-  , checkNumberFormat
-  , SomeCondition (..)
-  , JsonFormula (..)
-  , satisfiesFormula
-  , satisfies
-  , showJSONValue
-  , showJSONValueInline
+  ( Bound (..),
+    showBound,
+    Property (..),
+    Condition (..),
+    showCondition,
+    satisfiesTyped,
+    checkStringFormat,
+    checkNumberFormat,
+    SomeCondition (..),
+    JsonFormula (..),
+    satisfiesFormula,
+    satisfies,
+    showJSONValue,
+    showJSONValueInline,
   )
 where
 
@@ -20,8 +20,8 @@ import Algebra.Lattice
 import qualified Data.Aeson as A
 import qualified Data.ByteString.Lazy as BSL
 import qualified Data.Foldable as F
-import qualified Data.HashMap.Strict as HM
 import Data.Functor
+import qualified Data.HashMap.Strict as HM
 import Data.Int
 import Data.Kind
 import qualified Data.Map as M
@@ -67,30 +67,33 @@ data Property = Property
 data Condition :: JsonType -> Type where
   Exactly :: TypedValue t -> Condition t
   Maximum :: !(Bound Scientific) -> Condition 'Number
-  Minimum
-    :: !(Down (Bound (Down Scientific)))
-    -> Condition 'Number -- ^ this has the right Ord
+  Minimum ::
+    !(Down (Bound (Down Scientific))) ->
+    -- | this has the right Ord
+    Condition 'Number
   MultipleOf :: !Scientific -> Condition 'Number
   NumberFormat :: !Format -> Condition 'Number
   MaxLength :: !Integer -> Condition 'String
   MinLength :: !Integer -> Condition 'String
   Pattern :: !Pattern -> Condition 'String
   StringFormat :: !Format -> Condition 'String
-  Items
-    :: !(ForeachType JsonFormula)
-    -> !(Traced (Referenced Schema))
-    -> Condition 'Array
-  TupleItems
-    :: ![(ForeachType JsonFormula, Traced (Referenced Schema))]
-    -> Condition 'Array
+  Items ::
+    !(ForeachType JsonFormula) ->
+    !(Traced (Referenced Schema)) ->
+    Condition 'Array
+  TupleItems ::
+    ![(ForeachType JsonFormula, Traced (Referenced Schema))] ->
+    Condition 'Array
   MaxItems :: !Integer -> Condition 'Array
   MinItems :: !Integer -> Condition 'Array
   UniqueItems :: Condition 'Array
-  Properties
-    :: !(M.Map Text Property)
-    -> !(ForeachType JsonFormula) -- ^ formula for additional properties
-    -> !(Maybe (Traced (Referenced Schema))) -- ^ schema for additional properties, Nothing means bottom
-    -> Condition 'Object
+  Properties ::
+    !(M.Map Text Property) ->
+    -- | formula for additional properties
+    !(ForeachType JsonFormula) ->
+    -- | schema for additional properties, Nothing means bottom
+    !(Maybe (Traced (Referenced Schema))) ->
+    Condition 'Object
   MaxProperties :: !Integer -> Condition 'Object
   MinProperties :: !Integer -> Condition 'Object
 
@@ -118,13 +121,15 @@ showCondition = \case
   UniqueItems -> para "The elements in the array should be unique."
   (Properties props additional _) ->
     bulletList $
-      (M.toList props
-         <&> (\(k, p) ->
-                para (code k)
-                  <> para (strong $ if propRequired p then "Required" else "Optional")
-                  <> showForEachJsonFormula (propFormula p)))
+      ( M.toList props
+          <&> ( \(k, p) ->
+                  para (code k)
+                    <> para (strong $ if propRequired p then "Required" else "Optional")
+                    <> showForEachJsonFormula (propFormula p)
+              )
+      )
         <> [ para (emph "Additional properties")
-               <> showForEachJsonFormula additional
+              <> showForEachJsonFormula additional
            ]
   (MaxProperties n) -> para $ "The maximum number of fields should be " <> show' n <> "."
   (MinProperties n) -> para $ "The minimum number of fields should be " <> show' n <> "."
@@ -133,15 +138,17 @@ showCondition = \case
     showForEachJsonFormula i =
       bulletList $
         foldType
-          (\t f -> case getJsonFormula $ f i of
-             BottomDNF -> mempty
-             (DNF conds) ->
+          ( \t f -> case getJsonFormula $ f i of
+              BottomDNF -> mempty
+              (DNF conds) ->
                 [ para (describeJSONType t)
                     <> bulletList
-                      (S.toList conds <&> \case
-                         Disjunct (S.toList -> []) -> para "Empty"
-                         Disjunct (S.toList -> cond) -> bulletList (showCondition <$> cond))
-                ])
+                      ( S.toList conds <&> \case
+                          Disjunct (S.toList -> []) -> para "Empty"
+                          Disjunct (S.toList -> cond) -> bulletList (showCondition <$> cond)
+                      )
+                ]
+          )
 
 showJSONValue :: A.Value -> Blocks
 showJSONValue v = codeBlockWith ("", ["json"], mempty) (T.decodeUtf8 . BSL.toStrict . A.encode $ v)

src/Data/OpenApi/Compare/Validate/Schema/Partition.hs

@@ -1,15 +1,15 @@
 module Data.OpenApi.Compare.Validate.Schema.Partition
-  ( partitionSchema
-  , partitionRefSchema
-  , selectPartition
-  , runPartitionM
-  , tryPartition
-  , showPartition
-  , intersectSchema
-  , intersectRefSchema
-  , IntersectionResult (..)
-  , runIntersectionM
-  , Partition
+  ( partitionSchema,
+    partitionRefSchema,
+    selectPartition,
+    runPartitionM,
+    tryPartition,
+    showPartition,
+    intersectSchema,
+    intersectRefSchema,
+    IntersectionResult (..),
+    runIntersectionM,
+    Partition,
   )
 where
 
@@ -143,10 +143,11 @@ partitionCondition = \case
           Just _ -> top
           Nothing ->
             singletonPart $
-              DByProperties $ LiteralDNF
-                ( M.keysSet $ M.filter (not . propRequired) props
-                , M.keysSet $ M.filter propRequired props
-                )
+              DByProperties $
+                LiteralDNF
+                  ( M.keysSet $ M.filter (not . propRequired) props
+                  , M.keysSet $ M.filter propRequired props
+                  )
     inProps <- forM (M.toList $ M.filter propRequired props) $ \(k, prop) -> do
       f <- partitionRefSchema $ propRefSchema prop
       pure $ fmap (\(Partitions m) -> Partitions $ M.mapKeysMonotonic (PInProperty k) m) f
@@ -156,10 +157,10 @@ partitionCondition = \case
 runPartitionM :: Traced (Definitions Schema) -> PartitionM a -> a
 runPartitionM defs = runIdentity . runMemo () . (`runReaderT` defs)
 
-partitionJsonFormulas
-  :: ProdCons (Traced (Definitions Schema))
-  -> ProdCons (JsonFormula t)
-  -> Lifted Partitions
+partitionJsonFormulas ::
+  ProdCons (Traced (Definitions Schema)) ->
+  ProdCons (JsonFormula t) ->
+  Lifted Partitions
 partitionJsonFormulas defs pc = producer pcPart \/ consumer pcPart
   where
     pcPart = partitionFormula <$> defs <*> pc
@@ -211,11 +212,11 @@ runIntersectionM defs act = case runWriterT $ runReaderT act defs of
   Just (x, Any False) -> Same x
   Just (x, Any True) -> New x
 
-intersectSchema
-  :: PartitionLocation
-  -> PartitionChoice
-  -> Traced Schema
-  -> IntersectionM Schema
+intersectSchema ::
+  PartitionLocation ->
+  PartitionChoice ->
+  Traced Schema ->
+  IntersectionM Schema
 intersectSchema loc part sch = do
   allOf' <- forM (tracedAllOf sch) $ \rss ->
     -- Assuming i ranges over a nonempty set (checked in processSchema)
@@ -258,11 +259,11 @@ intersectSchema loc part sch = do
         pure $ sch' {_schemaEnum = Just enum'}
       CByProperties {} -> error "CByProperties not implemented"
 
-intersectRefSchema
-  :: PartitionLocation
-  -> PartitionChoice
-  -> Traced (Referenced Schema)
-  -> IntersectionM (Referenced Schema)
+intersectRefSchema ::
+  PartitionLocation ->
+  PartitionChoice ->
+  Traced (Referenced Schema) ->
+  IntersectionM (Referenced Schema)
 intersectRefSchema loc part rs = do
   defs <- R.ask
   Inline <$> intersectSchema loc part (dereference defs rs)

src/Data/OpenApi/Compare/Validate/Schema/Process.hs

@@ -1,11 +1,11 @@
 module Data.OpenApi.Compare.Validate.Schema.Process
-  ( schemaToFormula
+  ( schemaToFormula,
   )
 where
 
 import Algebra.Lattice
-import qualified Control.Monad.Reader as R
 import Control.Monad.Reader hiding (ask)
+import qualified Control.Monad.Reader as R
 import Control.Monad.State
 import Control.Monad.Writer
 import qualified Data.Aeson as A
@@ -71,10 +71,10 @@ warnKnot =
     , tieKnot = \_ -> pure
     }
 
-processRefSchema
-  :: MonadProcess m
-  => Traced (Referenced Schema)
-  -> m (ForeachType JsonFormula)
+processRefSchema ::
+  MonadProcess m =>
+  Traced (Referenced Schema) ->
+  m (ForeachType JsonFormula)
 processRefSchema x = do
   defs <- R.ask
   memoWithKnot warnKnot (processSchema $ dereference defs x) (ask x)
@@ -82,10 +82,10 @@ processRefSchema x = do
 -- | Turn a schema into a tuple of 'JsonFormula's that describes the condition
 -- for every possible type of a JSON value. The conditions are independent, and
 -- are thus checked independently.
-processSchema
-  :: MonadProcess m
-  => Traced Schema
-  -> m (ForeachType JsonFormula)
+processSchema ::
+  MonadProcess m =>
+  Traced Schema ->
+  m (ForeachType JsonFormula)
 processSchema sch@(extract -> Schema {..}) = do
   let singletonFormula :: Condition t -> JsonFormula t
       singletonFormula = JsonFormula . LiteralDNF
@@ -331,26 +331,27 @@ processSchema sch@(extract -> Schema {..}) = do
   pure $
     nullableClause
       \/ meets
-        (allClauses
-           <> [ anyClause
-              , oneClause
-              , typeClause
-              , enumClause
-              , maximumClause
-              , minimumClause
-              , multipleOfClause
-              , formatClause
-              , maxLengthClause
-              , minLengthClause
-              , patternClause
-              , itemsClause
-              , maxItemsClause
-              , minItemsClause
-              , uniqueItemsClause
-              , propertiesClause
-              , maxPropertiesClause
-              , minPropertiesClause
-              ])
+        ( allClauses
+            <> [ anyClause
+               , oneClause
+               , typeClause
+               , enumClause
+               , maximumClause
+               , minimumClause
+               , multipleOfClause
+               , formatClause
+               , maxLengthClause
+               , minLengthClause
+               , patternClause
+               , itemsClause
+               , maxItemsClause
+               , minItemsClause
+               , uniqueItemsClause
+               , propertiesClause
+               , maxPropertiesClause
+               , minPropertiesClause
+               ]
+        )
 
 {- TODO: ReadOnly/WriteOnly #68 -}
 
@@ -369,8 +370,8 @@ checkOneOfDisjoint schs = do
 runProcessM :: Traced (Definitions Schema) -> ProcessM a -> (a, P.PathsPrefixTree Behave AnIssue 'SchemaLevel)
 runProcessM defs = runWriter . (`runReaderT` defs) . runMemo ()
 
-schemaToFormula
-  :: Traced (Definitions Schema)
-  -> Traced Schema
-  -> (ForeachType JsonFormula, P.PathsPrefixTree Behave AnIssue 'SchemaLevel)
+schemaToFormula ::
+  Traced (Definitions Schema) ->
+  Traced Schema ->
+  (ForeachType JsonFormula, P.PathsPrefixTree Behave AnIssue 'SchemaLevel)
 schemaToFormula defs rs = runProcessM defs $ processSchema rs

src/Data/OpenApi/Compare/Validate/Schema/Traced.hs

@@ -1,18 +1,18 @@
 {-# OPTIONS_GHC -Wno-orphans #-}
 
 module Data.OpenApi.Compare.Validate.Schema.Traced
-  ( Step (..)
-  , tracedAllOf
-  , tracedAnyOf
-  , tracedOneOf
-  , tracedItems
-  , tracedAdditionalProperties
-  , tracedDiscriminator
-  , tracedProperties
-  , tracedConjunct
-  , PartitionLocation (..)
-  , PartitionChoice (..)
-  , Partition
+  ( Step (..),
+    tracedAllOf,
+    tracedAnyOf,
+    tracedOneOf,
+    tracedItems,
+    tracedAdditionalProperties,
+    tracedDiscriminator,
+    tracedProperties,
+    tracedConjunct,
+    PartitionLocation (..),
+    PartitionChoice (..),
+    Partition,
   )
 where
 

src/Data/OpenApi/Compare/Validate/Schema/TypedJson.hs

@@ -1,11 +1,11 @@
 module Data.OpenApi.Compare.Validate.Schema.TypedJson
-  ( JsonType (..)
-  , describeJSONType
-  , TypedValue (..)
-  , untypeValue
-  , ForeachType (..)
-  , foldType
-  , forType_
+  ( JsonType (..),
+    describeJSONType,
+    TypedValue (..),
+    untypeValue,
+    ForeachType (..),
+    foldType,
+    forType_,
   )
 where
 
@@ -88,24 +88,26 @@ forType_ :: Applicative m => (forall x. Typeable x => JsonType -> (ForeachType f
 forType_ k = getAp $ foldType (\ty proj -> Ap $ k ty proj)
 
 broadcastType :: (forall x. Typeable x => f x) -> ForeachType f
-broadcastType k = ForeachType
-  { forNull = k
-  , forBoolean = k
-  , forNumber = k
-  , forString = k
-  , forArray = k
-  , forObject = k
-  }
+broadcastType k =
+  ForeachType
+    { forNull = k
+    , forBoolean = k
+    , forNumber = k
+    , forString = k
+    , forArray = k
+    , forObject = k
+    }
 
 zipType :: (forall x. Typeable x => f x -> g x -> h x) -> ForeachType f -> ForeachType g -> ForeachType h
-zipType k f1 f2 = ForeachType
-  { forNull = k (forNull f1) (forNull f2)
-  , forBoolean = k (forBoolean f1) (forBoolean f2)
-  , forNumber = k (forNumber f1) (forNumber f2)
-  , forString = k (forString f1) (forString f2)
-  , forArray = k (forArray f1) (forArray f2)
-  , forObject = k (forObject f1) (forObject f2)
-  }
+zipType k f1 f2 =
+  ForeachType
+    { forNull = k (forNull f1) (forNull f2)
+    , forBoolean = k (forBoolean f1) (forBoolean f2)
+    , forNumber = k (forNumber f1) (forNumber f2)
+    , forString = k (forString f1) (forString f2)
+    , forArray = k (forArray f1) (forArray f2)
+    , forObject = k (forObject f1) (forObject f2)
+    }
 
 instance (forall x. Lattice (f x)) => Lattice (ForeachType f) where
   (\/) = zipType (\/)

src/Data/OpenApi/Compare/Validate/SecurityRequirement.hs

@@ -2,7 +2,7 @@
 {-# OPTIONS_GHC -Wno-orphans #-}
 
 module Data.OpenApi.Compare.Validate.SecurityRequirement
-  ( Issue (..)
+  ( Issue (..),
   )
 where
 
@@ -41,18 +41,19 @@ instance Subtree SecurityRequirement where
             for (IOHM.toList $ getSecurityRequirement sec) $ \(key, scopes) ->
               (,scopes) <$> lookupScheme key defs
     structuralMaybeWith
-      (\pc' -> do
-         let ProdCons pScopes cScopes = fmap snd <$> pc'
-         unless (pScopes == cScopes) structuralIssue
-         structuralList env $ fmap fst <$> pc'
-         pure ())
+      ( \pc' -> do
+          let ProdCons pScopes cScopes = fmap snd <$> pc'
+          unless (pScopes == cScopes) structuralIssue
+          structuralList env $ fmap fst <$> pc'
+          pure ()
+      )
       normalized
     pure ()
   checkSemanticCompatibility env bhv' pc = do
     let schemes = getH @(ProdCons (Traced (Definitions SecurityScheme))) env
         ( ProdCons pErrs cErrs
-          , (ProdCons pSchemes cSchemes)
-              :: ProdCons [(Behavior 'SecuritySchemeLevel, Traced SecurityScheme, [Text])]
+          , (ProdCons pSchemes cSchemes) ::
+              ProdCons [(Behavior 'SecuritySchemeLevel, Traced SecurityScheme, [Text])]
           ) =
             NE.unzip $
               partitionEithers <$> do

src/Data/OpenApi/Compare/Validate/Server.hs

@@ -1,7 +1,7 @@
 {-# OPTIONS_GHC -Wno-orphans #-}
 
 module Data.OpenApi.Compare.Validate.Server
-  ( Issue (..)
+  ( Issue (..),
   )
 where
 
@@ -31,9 +31,9 @@ import Data.Traversable
 import Text.Pandoc.Builder
 import Prelude as P
 
-tracedParsedServerUrlParts
-  :: Server
-  -> Either (Issue 'ServerLevel) ProcessedServer
+tracedParsedServerUrlParts ::
+  Server ->
+  Either (Issue 'ServerLevel) ProcessedServer
 tracedParsedServerUrlParts s =
   let parsedUrl = parseServerUrl $ _serverUrl s
       lookupVar var = case IOHM.lookup var (_serverVariables s) of
@@ -63,11 +63,12 @@ instance Subtree [Server] where
           pcServer
             <&> partitionEithers
               . fmap
-                (\(Traced t s) ->
-                   let bhv = beh >>> step (InServer $ _serverUrl s)
-                    in case tracedParsedServerUrlParts s of
-                         Left e -> Left $ issueAt bhv e
-                         Right u -> Right (bhv, Traced (t >>> step (ServerStep $ _serverUrl s)) u))
+                ( \(Traced t s) ->
+                    let bhv = beh >>> step (InServer $ _serverUrl s)
+                     in case tracedParsedServerUrlParts s of
+                          Left e -> Left $ issueAt bhv e
+                          Right u -> Right (bhv, Traced (t >>> step (ServerStep $ _serverUrl s)) u)
+                )
               . sequence
     sequenceA_ pErrs
     sequenceA_ cErrs

src/Data/OpenApi/Compare/Validate/Sums.hs

@@ -1,24 +1,25 @@
 module Data.OpenApi.Compare.Validate.Sums
-  ( checkSums
-  ) where
+  ( checkSums,
+  )
+where
 
 import Data.Foldable
 import Data.Map.Strict (Map)
 import qualified Data.Map.Strict as M
 import Data.OpenApi.Compare.Behavior
-import Data.OpenApi.Compare.Subtree
 import Data.OpenApi.Compare.Paths
+import Data.OpenApi.Compare.Subtree
 
-checkSums
-  :: (Ord k, Issuable l)
-  => Paths q r l
-  -> (k -> Issue l)
-  -> (k -> ProdCons t -> CompatFormula' q AnIssue r ())
-  -> ProdCons (Map k t)
-  -> CompatFormula' q AnIssue r ()
+checkSums ::
+  (Ord k, Issuable l) =>
+  Paths q r l ->
+  (k -> Issue l) ->
+  (k -> ProdCons t -> CompatFormula' q AnIssue r ()) ->
+  ProdCons (Map k t) ->
+  CompatFormula' q AnIssue r ()
 checkSums xs noElt check (ProdCons p c) = for_ (M.toList p) $ \(key, prodElt) ->
   case M.lookup key c of
     Nothing -> issueAt xs $ noElt key
     Just consElt ->
       let sumElts = ProdCons prodElt consElt
-      in check key sumElts
+       in check key sumElts

src/Data/OpenUnion/Extra.hs

@@ -1,7 +1,7 @@
 module Data.OpenUnion.Extra
-  ( (@@>)
-  , TryLiftUnion (..)
-  , pattern SingletonUnion
+  ( (@@>),
+    TryLiftUnion (..),
+    pattern SingletonUnion,
   )
 where
 
@@ -18,8 +18,8 @@ instance TryLiftUnion '[] where
   tryLiftUnion _ = empty
 
 instance
-  (Typeable y, SubList ys (y : ys), TryLiftUnion ys)
-  => TryLiftUnion (y ': ys)
+  (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

test/Spec/Golden/Extra.hs

@@ -1,8 +1,8 @@
 module Spec.Golden.Extra
-  ( getGoldenInputs
-  , getGoldenInputsUniform
-  , goldenInputsTree
-  , goldenInputsTreeUniform
+  ( getGoldenInputs,
+    getGoldenInputsUniform,
+    goldenInputsTree,
+    goldenInputsTreeUniform,
   )
 where
 
@@ -19,12 +19,12 @@ data TestInput t
   | TestInputLeaf TestName t FilePath
   deriving stock (Functor)
 
-getGoldenInputs
-  :: (Each s t (FilePath, FilePath -> IO a) a)
-  => TestName
-  -> FilePath
-  -> s
-  -> IO (TestInput t)
+getGoldenInputs ::
+  (Each s t (FilePath, FilePath -> IO a) a) =>
+  TestName ->
+  FilePath ->
+  s ->
+  IO (TestInput t)
 getGoldenInputs name filepath inp = do
   dirs' <- listDirectory filepath >>= filterM (doesDirectoryExist . (filepath </>))
   case dirs' of
@@ -39,32 +39,34 @@ getGoldenInputs name filepath inp = do
       TestInputNode name
         <$> forM dirs (\dir -> getGoldenInputs dir (filepath </> dir) inp)
 
-getGoldenInputsUniform
-  :: (Each t h (FilePath, FilePath -> IO a) a)
-  => (Each s t FilePath (FilePath, FilePath -> IO a))
-  => TestName
-  -> (FilePath -> IO a)
-  -> FilePath
-  -> s
-  -> IO (TestInput h)
+getGoldenInputsUniform ::
+  (Each t h (FilePath, FilePath -> IO a) a) =>
+  (Each s t FilePath (FilePath, FilePath -> IO a)) =>
+  TestName ->
+  (FilePath -> IO a) ->
+  FilePath ->
+  s ->
+  IO (TestInput h)
 getGoldenInputsUniform name f filepath inp = getGoldenInputs name filepath $ inp & each %~ (,f)
 
-goldenInputsTree
-  :: (Each s t (FilePath, FilePath -> IO a) a)
-  => TestName
-  -> FilePath -- ^ Root path
-  -> FilePath -- ^ Name of golden file
-  -> s
-  -> (t -> IO BSL.ByteString)
-  -> IO TestTree
+goldenInputsTree ::
+  (Each s t (FilePath, FilePath -> IO a) a) =>
+  TestName ->
+  -- | Root path
+  FilePath ->
+  -- | Name of golden file
+  FilePath ->
+  s ->
+  (t -> IO BSL.ByteString) ->
+  IO TestTree
 goldenInputsTree name filepath golden inp f = do
   runTestInputTree golden f <$> getGoldenInputs name filepath inp
 
-runTestInputTree
-  :: FilePath
-  -> (t -> IO BSL.ByteString)
-  -> TestInput t
-  -> TestTree
+runTestInputTree ::
+  FilePath ->
+  (t -> IO BSL.ByteString) ->
+  TestInput t ->
+  TestTree
 runTestInputTree golden f (TestInputNode name rest) =
   testGroup name (runTestInputTree golden f <$> rest)
 runTestInputTree golden f (TestInputLeaf name t path) =
@@ -74,16 +76,18 @@ runTestInputTree golden f (TestInputLeaf name t path) =
     (path </> golden)
     (f t)
 
-goldenInputsTreeUniform
-  :: ( Each t h (FilePath, FilePath -> IO a) a
-     , Each s t FilePath (FilePath, FilePath -> IO a)
-     )
-  => String
-  -> FilePath -- ^ Root path
-  -> FilePath -- ^ Name of golden file
-  -> s
-  -> (FilePath -> IO a)
-  -> (h -> IO BSL.ByteString)
-  -> IO TestTree
+goldenInputsTreeUniform ::
+  ( Each t h (FilePath, FilePath -> IO a) a
+  , Each s t FilePath (FilePath, FilePath -> IO a)
+  ) =>
+  String ->
+  -- | Root path
+  FilePath ->
+  -- | Name of golden file
+  FilePath ->
+  s ->
+  (FilePath -> IO a) ->
+  (h -> IO BSL.ByteString) ->
+  IO TestTree
 goldenInputsTreeUniform name filepath golden inp h =
   goldenInputsTree name filepath golden (inp & each %~ (,h))

test/Spec/Golden/TraceTree.hs

@@ -1,5 +1,5 @@
 module Spec.Golden.TraceTree
-  ( tests
+  ( tests,
   )
 where