GHC 9.6 support and CSS fixes (#139)

* Port to GHC 9.6

* Fix CSS paths.

app/Data/OpenApi/Compare/Options.hs

@@ -9,6 +9,7 @@ import Data.OpenApi.Compare.Report
 import GHC.Generics (Generic)
 import Options.Applicative
 import Options.Applicative.Help hiding (fullDesc)
+import Text.PrettyPrint.ANSI.Leijen ((<$$>),string)
 
 parseOptions :: IO Options
 parseOptions = customExecParser (prefs $ showHelpOnError) optionsParserInfo

app/Main.hs

@@ -2,6 +2,7 @@ module Main (main) where
 
 import Control.Monad
 import Control.Monad.Except
+import Control.Monad.Trans (lift)
 import Data.Aeson
 import qualified Data.ByteString.Lazy as BSL
 import Data.Default

compaREST.cabal

@@ -12,8 +12,8 @@ category:            Web
 build-type:          Simple
 extra-doc-files:     README.md
                      CHANGELOG.md
-tested-with:         GHC == 8.10.4
-extra-source-files: awsm-css/dist/awsm.min.css
+tested-with:         GHC == 9.6
+extra-source-files: css/awsm.min.css
 extra-source-files:
   test/golden/**/*.yaml
   test/golden/**/*.md
@@ -26,13 +26,14 @@ common common-options
     -Wno-safe
     -Wno-prepositive-qualified-module
     -Wno-missing-import-lists
+    -Wno-missing-kind-signatures
     -Wno-partial-fields
     -Wno-all-missed-specialisations
     -Wno-missing-local-signatures
     -Wno-unsafe
     -fconstraint-solver-iterations=0
   default-language:    Haskell2010
-  build-depends:       base >= 4.12.0.0 && < 4.16
+  build-depends:       base >= 4.12.0.0 && < 5
                      , text
 
 
@@ -165,6 +166,7 @@ executable compaREST
     , containers
     , doctemplates
     , pandoc-types
+    , prettyprinter-compat-ansi-wl-pprint
   ghc-options:         -threaded
                        -rtsopts
                        -with-rtsopts=-N

default.nix

@@ -38,7 +38,7 @@ let
             (inDirectory ./src)
             (inDirectory ./app)
             (inDirectory ./github-action)
-            ./awsm-css/dist/awsm.min.css
+            ./css/awsm.min.css
             ./LICENSE
           ];
         };

src/Data/OpenApi/Compare/PathsPrefixTree.hs

@@ -23,7 +23,8 @@ where
 import Control.Monad
 import Data.Aeson
 import Data.Foldable hiding (null, toList)
-import qualified Data.HashMap.Strict as HM
+import qualified Data.Aeson.Key as Key
+import qualified Data.Aeson.KeyMap as KeyMap
 import Data.Kind
 import qualified Data.Map as M
 import Data.Monoid
@@ -256,7 +257,7 @@ newtype MergableObject = MergableObject {getMergableObject :: Object}
 
 instance Semigroup MergableObject where
   (MergableObject x) <> (MergableObject y) =
-    MergableObject $ HM.unionWith mergeValue x y
+    MergableObject $ KeyMap.unionWith mergeValue x y
     where
       mergeValue :: Value -> Value -> Value
       mergeValue (Object a) (Object b) =
@@ -271,6 +272,6 @@ instance Monoid MergableObject where
 
 traceObject :: Paths q r a -> Value -> Object
 traceObject Root (Object o) = o
-traceObject Root v = HM.singleton "root" v
+traceObject Root v = KeyMap.singleton "root" v
 traceObject (root `Snoc` s) v =
-  traceObject root . Object $ HM.singleton (T.pack . show $ s) v
+  traceObject root . Object $ KeyMap.singleton (Key.fromText . T.pack . show $ s) v

src/Data/OpenApi/Compare/Report.hs

@@ -198,7 +198,7 @@ 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

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

@@ -36,4 +36,4 @@ template =
          \</html>"
 
 awsmCss :: ByteString
-awsmCss = $(makeRelativeToProject "awsm-css/dist/awsm.min.css" >>= embedFile)
+awsmCss = $(makeRelativeToProject "css/awsm.min.css" >>= embedFile)

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

@@ -38,7 +38,8 @@ tracedSecuritySchemes :: Traced OpenApi -> Traced (Definitions SecurityScheme)
 tracedSecuritySchemes oa =
   traced
     (ask oa >>> step ComponentsSecurityScheme)
-    (_componentsSecuritySchemes . _openApiComponents . extract $ oa)
+    (unSecurityDefinitions . _componentsSecuritySchemes . _openApiComponents . extract $ oa)
+  where unSecurityDefinitions (SecurityDefinitions ds) = ds
 
 tracedResponses :: Traced OpenApi -> Traced (Definitions Response)
 tracedResponses oa =

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

@@ -5,7 +5,7 @@ module Data.OpenApi.Compare.Validate.Schema
   )
 where
 
-import Control.Monad.Writer
+import Control.Monad (when,unless)
 import qualified Data.Aeson as A
 import Data.Coerce
 import Data.Foldable (for_, toList)

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

@@ -18,10 +18,11 @@ where
 
 import Algebra.Lattice
 import qualified Data.Aeson as A
+import qualified Data.Aeson.Key as Key
+import qualified Data.Aeson.KeyMap as KeyMap
 import qualified Data.ByteString.Lazy as BSL
 import qualified Data.Foldable as F
 import Data.Functor
-import qualified Data.HashMap.Strict as HM
 import Data.Int
 import Data.Kind
 import qualified Data.Map as M
@@ -39,7 +40,7 @@ import Data.Text (Text)
 import qualified Data.Text as T
 import qualified Data.Text.Encoding as T
 import Data.Typeable
-import Text.Pandoc.Builder hiding (Format, Null)
+import Text.Pandoc.Builder hiding (Format)
 import Text.Regex.Pcre2
 
 data Bound a = Exclusive !a | Inclusive !a
@@ -177,10 +178,10 @@ satisfiesTyped (TArray a) (MaxItems m) = fromIntegral (F.length a) <= m
 satisfiesTyped (TArray a) (MinItems m) = fromIntegral (F.length a) >= m
 satisfiesTyped (TArray a) UniqueItems = S.size (S.fromList $ F.toList a) == F.length a -- TODO: could be better #36
 satisfiesTyped (TObject o) (Properties props additional _) =
-  all (`HM.member` o) (M.keys (M.filter propRequired props))
-    && all (\(k, v) -> satisfies v $ maybe additional propFormula $ M.lookup k props) (HM.toList o)
-satisfiesTyped (TObject o) (MaxProperties m) = fromIntegral (HM.size o) <= m
-satisfiesTyped (TObject o) (MinProperties m) = fromIntegral (HM.size o) >= m
+  all (`KeyMap.member` o) (map Key.fromText $ M.keys (M.filter propRequired props))
+    && all (\(k, v) -> satisfies v $ maybe additional propFormula $ M.lookup (Key.toText k) props) (KeyMap.toList o)
+satisfiesTyped (TObject o) (MaxProperties m) = fromIntegral (KeyMap.size o) <= m
+satisfiesTyped (TObject o) (MinProperties m) = fromIntegral (KeyMap.size o) >= m
 
 checkNumberFormat :: Format -> Scientific -> Bool
 checkNumberFormat "int32" (toRational -> n) =

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

@@ -16,6 +16,7 @@ where
 import Algebra.Lattice
 import Algebra.Lattice.Lifted
 import Control.Applicative
+import Control.Monad (when)
 import Control.Monad.Reader hiding (ask)
 import qualified Control.Monad.Reader as R
 import Control.Monad.State
@@ -31,6 +32,7 @@ import qualified Data.List as L
 import qualified Data.List.NonEmpty as NE
 import qualified Data.Map as M
 import Data.Maybe
+import Data.Monoid
 import Data.OpenApi
 import Data.OpenApi.Compare.Memo
 import Data.OpenApi.Compare.References
@@ -43,7 +45,8 @@ import Data.Ord
 import qualified Data.Set as S
 import Data.Text (Text)
 import qualified Data.Text as T
-import Text.Pandoc.Builder hiding (Format, Null)
+import Data.Traversable (forM)
+import Text.Pandoc.Builder hiding (Format)
 
 data PartitionData
   = DByEnumValue (DNF (S.Set A.Value))

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

@@ -13,6 +13,7 @@ import Data.Functor.Identity
 import qualified Data.HashMap.Strict.InsOrd as IOHM
 import qualified Data.Map as M
 import Data.Maybe
+import Data.Monoid
 import Data.OpenApi hiding (get)
 import Data.OpenApi.Compare.Behavior
 import Data.OpenApi.Compare.Memo
@@ -28,6 +29,7 @@ import Data.OpenApi.Compare.Validate.Schema.Traced
 import Data.OpenApi.Compare.Validate.Schema.TypedJson
 import Data.Ord
 import qualified Data.Set as S
+import Data.Traversable (forM)
 
 -- | A fake writer monad that doesn't actually record anything and allows lazy recursion.
 newtype Silent w a = Silent {runSilent :: a}

stack.yaml

@@ -1,11 +1,19 @@
-resolver: lts-18.27
+resolver: lts-22.17
 
 packages:
   - .
 
 extra-deps:
+  - base16-bytestring-1.0.2.0
+  - freer-simple-1.2.1.2
+  - github-0.29
+  - http-link-header-1.2.1
   - open-union-0.4.0.0
   - type-fun-0.1.3
-  - github-0.26
-  - base16-bytestring-0.1.1.7
-  - http-link-header-1.0.3.1
+  - typerep-map-0.6.0.0
+
+# Required for freer-simple and typerep-map
+allow-newer: true
+
+nix:
+  packages: [pkg-config zlib]