From bb636d432a9a856ef302c28b3c5377853ec701d7 Mon Sep 17 00:00:00 2001
From: Alexander Vershilov <alexander.vershilov@sirius.online>
Date: Sun, 14 Apr 2024 20:25:45 +0200
Subject: [PATCH] Support GHC-9.4.8

---
 src/Servant/EDE.hs                   | 21 ++++++++++++---------
 src/Servant/EDE/Internal/ToObject.hs | 16 ++++++++++------
 src/Servant/EDE/Internal/Validate.hs |  1 -
 3 files changed, 22 insertions(+), 16 deletions(-)

diff --git a/src/Servant/EDE.hs b/src/Servant/EDE.hs
index 1b5873b..9fdbb7b 100644
--- a/src/Servant/EDE.hs
+++ b/src/Servant/EDE.hs
@@ -53,11 +53,14 @@ import Data.Traversable (traverse)
 
 import Control.Concurrent
 import Control.Monad.IO.Class
+import qualified Data.Aeson.KeyMap as KeyMap
+import qualified Data.Aeson.Key as Key
 import Data.Aeson (Object, Value(..))
+import Data.Bifunctor (first)
 import Data.Foldable (fold)
+import Data.Kind
 import Data.HashMap.Strict (HashMap, (!),fromList)
 import Data.Proxy
-import Data.Semigroup
 import Data.Text (Text)
 import Data.Text.Lazy.Encoding (encodeUtf8)
 import GHC.TypeLits
@@ -185,7 +188,7 @@ loadTemplates' proxy templatedir =
 --
 -- A complete, runnable version of this can be found
 -- in the @examples@ folder of the git repository.
-data Tpl (ct :: *) (file :: Symbol)
+data Tpl (ct :: Type) (file :: Symbol)
 
 -- the filename doesn't matter for the content type,
 -- as long as 'ct' is a valid one (html, json, css, etc or application-specific)
@@ -195,14 +198,16 @@ instance Accept ct => Accept (Tpl ct file) where
 
 instance (KnownSymbol file, Accept ct, ToObject a) => MimeRender (Tpl ct file) a where
   mimeRender _ val = encodeUtf8 . result (error . show) id $
-    renderWith flts templ (toObject val)
+    renderWith flts templ (mkObject val)
 
     where templ = tmap ! filename
           filename = symbolVal (Proxy :: Proxy file)
           tmplfs = unsafePerformIO (readMVar __template_store)
           tmap = templateMap $ _templates tmplfs
           flts = _filters tmplfs
+          mkObject = fromList . map (first Key.toText) . KeyMap.toList . toObject
 
+          
 
 __template_store :: MVar TemplatesAndFilters
 __template_store = unsafePerformIO newEmptyMVar
@@ -258,10 +263,10 @@ instance (KnownSymbol file, ToObject a) => MimeRender (HTML file) a where
     sanitizeObject (toObject val)
 
 sanitizeObject :: Object -> Object
-sanitizeObject = HM.fromList . map sanitizeKV . HM.toList
+sanitizeObject = KeyMap.fromList . map sanitizeKV . KeyMap.toList
 
-sanitizeKV :: (Text, Value) -> (Text, Value)
-sanitizeKV (k, v) = (sanitize k, sanitizeValue v)
+sanitizeKV :: (Key.Key, Value) -> (Key.Key, Value)
+sanitizeKV (k, v) = (Key.fromText  . sanitize $ Key.toText k, sanitizeValue v)
 
 sanitizeValue :: Value -> Value
 sanitizeValue (String s) = String (sanitize s)
@@ -291,7 +296,7 @@ type instance TemplateFiles (Post cs a)   = CTFiles cs
 type instance TemplateFiles (Put cs a)    = CTFiles cs
 type instance TemplateFiles Raw           = '[]
 
-type family CTFiles (cts :: [*]) :: [Symbol] where
+type family CTFiles (cts :: [Type]) :: [Symbol] where
   CTFiles '[]        = '[]
   CTFiles (c ': cts) = Append (CTFile c) (CTFiles cts)
 
@@ -326,8 +331,6 @@ instance Semigroup Templates where
 instance Monoid Templates where
   mempty = Templates mempty
 
-  a `mappend` b = a <> b
-
 -- A data type that holds both the compiled templates and
 -- any passed-in custom filters
 data TemplatesAndFilters = TemplatesAndFilters {
diff --git a/src/Servant/EDE/Internal/ToObject.hs b/src/Servant/EDE/Internal/ToObject.hs
index f20ae3a..a1b6763 100644
--- a/src/Servant/EDE/Internal/ToObject.hs
+++ b/src/Servant/EDE/Internal/ToObject.hs
@@ -6,8 +6,9 @@
 module Servant.EDE.Internal.ToObject where
 
 import Data.Aeson
-import Data.HashMap.Strict
-import Data.Monoid
+import qualified Data.Aeson.KeyMap as KeyMap
+import qualified Data.Aeson.Key as Key
+import qualified Data.HashMap.Strict as HashMap
 import Data.Text
 import GHC.Generics
 
@@ -42,14 +43,17 @@ class ToObject a where
   --
   -- @ 
   -- -- Reminder:
-  -- type Object = 'HashMap' 'Text' 'Value'
+  -- type Object = 'KeyMap' 'Value'
   -- @
   toObject :: a -> Object
   
   default toObject :: (Generic a, GToObject (Rep a)) => a -> Object
   toObject = genericToObject
 
-instance ToObject (HashMap Text Value) where
+instance ToObject (HashMap.HashMap Text Value) where
+  toObject hm = KeyMap.fromList [(Key.fromText k, v) | (k,v) <- HashMap.toList hm]
+
+instance ToObject (KeyMap.KeyMap Value) where
   toObject = id
 
 class GToObject f where
@@ -72,8 +76,8 @@ instance GToObject a => GToObject (M1 C c a) where
   gtoObject (M1 x) = gtoObject x
 
 instance (Selector s, ToJSON a) => GToObject (M1 S s (K1 r a)) where
-  gtoObject s@(M1 (K1 x)) = fromList [(fieldname, value)]
-    where fieldname = pack (selName s)
+  gtoObject s@(M1 (K1 x)) = KeyMap.fromList [(fieldname, value)]
+    where fieldname = Key.fromText (pack (selName s))
           value     = toJSON x
 
 genericToObject :: (Generic a, GToObject (Rep a)) => a -> Object
diff --git a/src/Servant/EDE/Internal/Validate.hs b/src/Servant/EDE/Internal/Validate.hs
index 86ad100..c03dbd5 100644
--- a/src/Servant/EDE/Internal/Validate.hs
+++ b/src/Servant/EDE/Internal/Validate.hs
@@ -8,7 +8,6 @@ import Data.Traversable
 #endif
 
 import Data.Functor.Compose
-import Data.Semigroup
 
 data Validated e a = OK a | NotOK e
   deriving (Eq, Show)