From 2542e9078b74db3c93f0cc64b6389ab7145e7d51 Mon Sep 17 00:00:00 2001
From: Evgeny Poberezkin <evgeny@poberezkin.com>
Date: Mon, 14 Apr 2025 11:01:31 +0100
Subject: [PATCH] option sortRecordFields

---
 src/Data/Aeson.hs                |  1 +
 src/Data/Aeson/TH.hs             |  9 ++++++---
 src/Data/Aeson/Types.hs          |  1 +
 src/Data/Aeson/Types/Internal.hs | 10 +++++++++-
 tests/UnitTests.hs               |  1 +
 5 files changed, 18 insertions(+), 4 deletions(-)

diff --git a/src/Data/Aeson.hs b/src/Data/Aeson.hs
index a3b6fb41c..9ffcf1324 100644
--- a/src/Data/Aeson.hs
+++ b/src/Data/Aeson.hs
@@ -134,6 +134,7 @@ module Data.Aeson
     , nullaryToObject
     , omitNothingFields
     , allowOmittedFields
+    , sortRecordFields
     , sumEncoding
     , unwrapUnaryRecords
     , tagSingleConstructors
diff --git a/src/Data/Aeson/TH.hs b/src/Data/Aeson/TH.hs
index c1300b505..065bca3f6 100644
--- a/src/Data/Aeson/TH.hs
+++ b/src/Data/Aeson/TH.hs
@@ -124,13 +124,14 @@ import Data.Aeson.Key (Key)
 import qualified Data.Aeson.Key as Key
 import qualified Data.Aeson.KeyMap as KM
 import Data.Foldable (foldr')
-import Data.List (genericLength, intercalate, union)
+import Data.List (genericLength, intercalate, sortOn, union)
 import Data.List.NonEmpty ((<|), NonEmpty((:|)))
 import Data.Map (Map)
 import qualified Data.Monoid as Monoid
 import Data.Set (Set)
 import Language.Haskell.TH hiding (Arity)
 import Language.Haskell.TH.Datatype
+import qualified Language.Haskell.TH.Syntax as THS
 import Text.Printf (printf)
 import qualified Data.Aeson.Encoding.Internal as E
 import qualified Data.List.NonEmpty as NE (length, reverse)
@@ -461,8 +462,10 @@ argsToValue letInsert target jc tvMap opts multiCons
 
         argTys' <- mapM resolveTypeSynonyms argTys
         args <- newNameList "arg" $ length argTys'
-        let argCons = zip3 (map varE args) argTys' fields
-
+        let argCons_ = zip3 (map varE args) argTys' fields
+            argCons
+              | sortRecordFields opts = sortOn (\(_, _, THS.Name (THS.OccName name) _) -> name) argCons_
+              | otherwise = argCons_
             toPair (arg, argTy, fld) =
               let fieldName = fieldLabel opts fld
                   toValue = dispatchToJSON target jc conName tvMap argTy
diff --git a/src/Data/Aeson/Types.hs b/src/Data/Aeson/Types.hs
index ee603e6cc..9d84a630d 100644
--- a/src/Data/Aeson/Types.hs
+++ b/src/Data/Aeson/Types.hs
@@ -145,6 +145,7 @@ module Data.Aeson.Types
     , nullaryToObject
     , omitNothingFields
     , allowOmittedFields
+    , sortRecordFields
     , sumEncoding
     , unwrapUnaryRecords
     , tagSingleConstructors
diff --git a/src/Data/Aeson/Types/Internal.hs b/src/Data/Aeson/Types/Internal.hs
index f094ccc47..cbd8524d6 100644
--- a/src/Data/Aeson/Types/Internal.hs
+++ b/src/Data/Aeson/Types/Internal.hs
@@ -59,6 +59,7 @@ module Data.Aeson.Types.Internal
         , nullaryToObject
         , omitNothingFields
         , allowOmittedFields
+        , sortRecordFields
         , sumEncoding
         , unwrapUnaryRecords
         , tagSingleConstructors
@@ -733,6 +734,11 @@ data Options = Options
       -- ^ If 'True', missing fields of a record will be filled
       -- with 'omittedField' values (if they are 'Just').
       -- If 'False', all fields will required to present in the record object.
+    , sortRecordFields :: Bool
+      -- ^ If 'True, fields will be sorted alphabetically in record encodings.
+      -- This is useful for comparing JSON encodings
+      -- or when the whole or some parts of JSON encoding needs to be signed,
+      -- to avoid multi-stage encoding/decoding for signing and signature verification.
     , sumEncoding :: SumEncoding
       -- ^ Specifies how to encode constructors of a sum datatype.
     , unwrapUnaryRecords :: Bool
@@ -748,7 +754,7 @@ data Options = Options
     }
 
 instance Show Options where
-  show (Options f c a n o q s u t r) =
+  show (Options f c a n o q d s u t r) =
        "Options {"
     ++ intercalate ", "
       [ "fieldLabelModifier =~ " ++ show (f "exampleField")
@@ -757,6 +763,7 @@ instance Show Options where
       , "nullaryToObject = " ++ show n
       , "omitNothingFields = " ++ show o
       , "allowOmittedFields = " ++ show q
+      , "sortRecordFields = " ++ show d
       , "sumEncoding = " ++ show s
       , "unwrapUnaryRecords = " ++ show u
       , "tagSingleConstructors = " ++ show t
@@ -854,6 +861,7 @@ defaultOptions = Options
                  , nullaryToObject         = False
                  , omitNothingFields       = False
                  , allowOmittedFields      = True
+                 , sortRecordFields        = False
                  , sumEncoding             = defaultTaggedObject
                  , unwrapUnaryRecords      = False
                  , tagSingleConstructors   = False
diff --git a/tests/UnitTests.hs b/tests/UnitTests.hs
index 74725b679..b69697f3d 100644
--- a/tests/UnitTests.hs
+++ b/tests/UnitTests.hs
@@ -281,6 +281,7 @@ showOptions =
         ++ ", nullaryToObject = False"
         ++ ", omitNothingFields = False"
         ++ ", allowOmittedFields = True"
+        ++ ", sortRecordFields = False"
         ++ ", sumEncoding = TaggedObject {tagFieldName = \"tag\", contentsFieldName = \"contents\"}"
         ++ ", unwrapUnaryRecords = False"
         ++ ", tagSingleConstructors = False"