Dump the project JSON respecting field order.

Author: philderbeast

src/Stack/ConfigCmd.hs

@@ -48,7 +48,8 @@ import           Stack.Prelude
 import           Data.Coerce (coerce)
 import           Pantry.Internal.AesonExtended
                  (ToJSON(..), FromJSON, (.=), WithJSONWarnings (WithJSONWarnings), object)
-import Data.Aeson.Encode.Pretty (encodePretty)
+import Data.Aeson.Encode.Pretty (encodePretty, encodePretty', confCompare)
+import qualified Data.Aeson.Encode.Pretty as Aeson (defConfig)
 import qualified Data.Aeson.Key as Key
 import Data.Aeson.KeyMap (KeyMap)
 import qualified Data.Aeson.KeyMap as KeyMap
@@ -128,10 +129,16 @@ configCmdSetScope (ConfigCmdSetSystemGhc scope _) = scope
 configCmdSetScope (ConfigCmdSetInstallGhc scope _) = scope
 
 encodeDumpProject :: RawYaml -> ConfigDumpFormat -> Project -> ByteString
-encodeDumpProject _ ConfigDumpJson = toStrictBytes . encodePretty
-encodeDumpProject rawConfig ConfigDumpYaml = \p -> let e = Yaml.encode p in
+encodeDumpProject rawConfig ConfigDumpYaml p = let e = Yaml.encode p in
     Yaml.decodeEither' e & either (const e) (\(d :: KeyMap Yaml.Value) ->
         either (const e) encodeUtf8 (cfgRedress rawConfig d ""))
+encodeDumpProject rawConfig ConfigDumpJson p = let e = Yaml.encode p in
+    Yaml.decodeEither' e & either (const e) (\(d :: KeyMap Yaml.Value) ->
+        toStrictBytes $ encodePretty' (Aeson.defConfig{confCompare = cfgKeyCompare rawConfig d ""}) d)
+
+cfgKeyCompare :: RawYaml -> KeyMap Yaml.Value -> Text -> (Text -> Text -> Ordering)
+cfgKeyCompare (yamlLines -> configLines) (fmap Key.toText . KeyMap.keys -> keys) cmdKey =
+    compareInOrder configLines (coerce keys) (coerce cmdKey)
 
 encodeDumpStackBy :: ToJSON a => (Config -> a) -> ConfigCmdDumpStack -> (Config -> ByteString)
 encodeDumpStackBy f (ConfigCmdDumpStack _ ConfigDumpYaml) = Yaml.encode . f

src/Stack/YamlUpdate.hs

@@ -14,7 +14,8 @@
 --
 -- Use yamlLines to transform 'RawYaml' to ['RawYamlLine'].
 module Stack.YamlUpdate
-  ( encodeInOrder
+  ( compareInOrder
+  , encodeInOrder
   , redress
   , mkRaw
   , unmkRaw
@@ -131,28 +132,37 @@ fetchInRange YamlLines{blanks, wholeLineComments, partLineComments} p =
       ps = filterLineNumber partLineComments
   in  (ps, L.sortOn commentLineNumber $ ls ++ cs)
 
+-- | From an ordered list of keys constructs a comparison respecting that order.
+preservingCompare :: Ord a => Map Text a -> [Text] -> Text -> Text -> Text -> Ordering
+preservingCompare ixMap keysFound k x y =
+  -- If updating then preserve order but if inserting then put last.
+  if | k `L.elem` keysFound -> Map.lookup x ixMap `compare` Map.lookup y ixMap
+     | k == x, k == y -> EQ
+     | k == x -> GT
+     | k == y -> LT
+     | otherwise -> Map.lookup x ixMap `compare` Map.lookup y ixMap
+
+-- | From an ordered list of YAML lines constructs a comparison respecting that order.
+compareInOrder :: [RawYamlLine]
+               -> [YamlKey]
+               -> YamlKey
+               -> (Text -> Text -> Ordering)
+compareInOrder rawLines keysFound (YamlKey k) =
+  let keyLine = findKeyLine rawLines
+      ixMap = Map.fromList $ (\yk@(YamlKey x) -> (x, keyLine yk)) <$> keysFound
+
+  in preservingCompare ixMap (coerce <$> keysFound) k
+
 -- | Uses the order of the keys in the original to preserve the order in the
 -- update except that inserting a key orders it last.
 encodeInOrder :: [RawYamlLine]
               -> [YamlKey]
               -> YamlKey
               -> Yaml.Object
               -> Either UnicodeException RawYaml
-encodeInOrder rawLines keysFound upsertKey@(YamlKey k) yObject =
-  let keyLine = findKeyLine rawLines
-      ixMap = Map.fromList $ (\yk@(YamlKey x) -> (x, keyLine yk)) <$> keysFound
-      preservingCompare x y =
-        -- If updating then preserve order but if inserting then put last.
-        if | upsertKey `L.elem` keysFound ->
-               Map.lookup x ixMap `compare` Map.lookup y ixMap
-           | k == x, k == y -> EQ
-           | k == x -> GT
-           | k == y -> LT
-           | otherwise -> Map.lookup x ixMap `compare` Map.lookup y ixMap
-
-      keyCmp = Yaml.setConfCompare preservingCompare Yaml.defConfig
-
-  in  RawYaml <$> decodeUtf8' (Yaml.encodePretty keyCmp yObject)
+encodeInOrder rawLines keysFound key yObject =
+  let keyCmp = Yaml.setConfCompare (compareInOrder rawLines keysFound key) Yaml.defConfig
+  in RawYaml <$> decodeUtf8' (Yaml.encodePretty keyCmp yObject)
 
 endSentinel :: Text
 endSentinel =