From d814801c3a21dc0d63d8e4bb0ea0b40fe9abf77a Mon Sep 17 00:00:00 2001 From: Mike Pilgrem Date: Tue, 13 Sep 2022 22:00:14 +0100 Subject: [PATCH] Fix #5861 Amend YAML file without affecting its order --- package.yaml | 1 - src/Stack/ConfigCmd.hs | 110 +++++++++++++++----- src/Stack/YamlUpdate.hs | 222 ---------------------------------------- stack.cabal | 1 - 4 files changed, 85 insertions(+), 249 deletions(-) delete mode 100644 src/Stack/YamlUpdate.hs diff --git a/package.yaml b/package.yaml index 750ca894d7..aa667c604f 100644 --- a/package.yaml +++ b/package.yaml @@ -262,7 +262,6 @@ library: - Stack.Unpack - Stack.Upgrade - Stack.Upload - - Stack.YamlUpdate - System.Info.ShortPathName - System.Permissions - System.Process.Pager diff --git a/src/Stack/ConfigCmd.hs b/src/Stack/ConfigCmd.hs index b5d45d51fb..7a6d224435 100644 --- a/src/Stack/ConfigCmd.hs +++ b/src/Stack/ConfigCmd.hs @@ -17,10 +17,10 @@ module Stack.ConfigCmd ,cfgCmdName) where import Stack.Prelude -import Data.Coerce (coerce) import qualified Data.Aeson.Key as Key import qualified Data.Aeson.KeyMap as KeyMap -import Data.ByteString.Builder (byteString) +import Data.Attoparsec.Text as P (Parser, parseOnly, skip, skipWhile, + string, takeText, takeWhile) import qualified Data.Map.Merge.Strict as Map import qualified Data.Text as T import qualified Data.Yaml as Yaml @@ -37,7 +37,6 @@ import Stack.Constants import Stack.Types.Config import Stack.Types.Resolver import System.Environment (getEnvironment) -import Stack.YamlUpdate data ConfigCmdSet = ConfigCmdSetResolver (Unresolved AbstractResolver) @@ -73,29 +72,90 @@ cfgCmdSet cmd = do PCGlobalProject -> liftM ( stackDotYaml) (getImplicitGlobalProjectDir conf) PCNoProject _extraDeps -> throwString "config command used when no project configuration available" -- maybe modify the ~/.stack/config.yaml file instead? CommandScopeGlobal -> return (configUserConfigPath conf) - -- We don't need to worry about checking for a valid yaml here - rawConfig <- mkRaw <$> liftIO (readFileUtf8 (toFilePath configFilePath)) - (config :: Yaml.Object) <- either throwM return (Yaml.decodeEither' . encodeUtf8 $ coerce rawConfig) + rawConfig <- liftIO (readFileUtf8 (toFilePath configFilePath)) + config <- either throwM return (Yaml.decodeEither' $ encodeUtf8 rawConfig) newValue <- cfgCmdSetValue (parent configFilePath) cmd - let cmdKey = cfgCmdSetOptionName cmd - config' = KeyMap.insert (Key.fromText cmdKey) newValue config - yamlKeys = Key.toText <$> KeyMap.keys config - if config' == config - then logInfo - (fromString (toFilePath configFilePath) <> - " already contained the intended configuration and remains \ - \unchanged.") - else do - let configLines = yamlLines rawConfig - either - throwM - (\updated -> do - let redressed = unmkRaw $ redress configLines updated - writeBinaryFileAtomic configFilePath . byteString $ encodeUtf8 redressed - - let file = fromString $ toFilePath configFilePath - logInfo (file <> " has been updated.")) - (encodeInOrder configLines (coerce yamlKeys) (coerce cmdKey) config') + let yamlLines = T.lines rawConfig + cmdKey = cfgCmdSetOptionName cmd -- Text + cmdKey' = Key.fromText cmdKey -- Data.Aeson.Key.Key + newValue' = T.stripEnd $ + decodeUtf8With lenientDecode $ Yaml.encode newValue -- Text + file = toFilePath configFilePath -- String + file' = display $ T.pack file -- Utf8Builder + newYamlLines <- case KeyMap.lookup cmdKey' config of + Nothing -> do + logInfo $ file' <> " has been extended." + pure $ yamlLines <> [cmdKey <> ": " <> newValue'] + Just oldValue -> if oldValue == newValue + then do + logInfo $ file' <> " already contained the intended \ + \configuration and remains unchanged." + pure yamlLines + else switchLine file' cmdKey newValue' [] yamlLines + liftIO $ writeFileUtf8 file (T.unlines newYamlLines) + where + switchLine file cmdKey _ searched [] = do + logWarn $ display cmdKey <> " not found in YAML file " <> file <> + " as a single line. Multi-line key:value formats are not supported." + pure $ reverse searched + switchLine file cmdKey newValue searched (oldLine:rest) = + case parseOnly (parseLine cmdKey) oldLine of + Left _ -> + switchLine file cmdKey newValue (oldLine:searched) rest + Right (kt, spaces1, spaces2, comment) -> do + let newLine = renderKey cmdKey kt <> spaces1 <> ":" <> + spaces2 <> newValue <> comment + logInfo $ file <> " has been updated." + pure $ reverse searched <> (newLine:rest) + + -- This assumes that a top-level key will not be indented in the YAML file. + parseLine :: Text -> Parser (KeyType, Text, Text, Text) + parseLine key = do + kt <- parseKey key + spaces1 <- P.takeWhile (== ' ') + skip (== ':') + spaces2 <- P.takeWhile (== ' ') + skipWhile (/= ' ') + comment <- takeText + pure (kt, spaces1, spaces2, comment) + + -- If the key is, for example, install-ghc, this recognises install-ghc, + -- 'install-ghc' or "install-ghc". + parseKey :: Text -> Parser KeyType + parseKey k = parsePlainKey k + <|> parseSingleQuotedKey k + <|> parseDoubleQuotedKey k + + parsePlainKey :: Text -> Parser KeyType + parsePlainKey key = do + _ <- string key + pure PlainKey + + parseSingleQuotedKey :: Text -> Parser KeyType + parseSingleQuotedKey = parseQuotedKey SingleQuotedKey '\'' + + parseDoubleQuotedKey :: Text -> Parser KeyType + parseDoubleQuotedKey = parseQuotedKey DoubleQuotedKey '"' + + parseQuotedKey :: KeyType -> Char -> Text -> Parser KeyType + parseQuotedKey kt c key = do + skip (==c) + _ <- string key + skip (==c) + pure kt + + renderKey :: Text -> KeyType -> Text + renderKey key kt = case kt of + PlainKey -> key + SingleQuotedKey -> '\'' `T.cons` key `T.snoc` '\'' + DoubleQuotedKey -> '"' `T.cons` key `T.snoc` '"' + +-- |Type representing types of representations of keys in YAML files. +data KeyType + = PlainKey -- ^ For example: install-ghc + | SingleQuotedKey -- ^ For example: 'install-ghc' + | DoubleQuotedKey -- ^ For example: "install-ghc" + deriving (Eq, Show) cfgCmdSetValue :: (HasConfig env, HasGHCVariant env) diff --git a/src/Stack/YamlUpdate.hs b/src/Stack/YamlUpdate.hs deleted file mode 100644 index acc96004d6..0000000000 --- a/src/Stack/YamlUpdate.hs +++ /dev/null @@ -1,222 +0,0 @@ -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE MultiWayIf #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ParallelListComp #-} -{-# LANGUAGE ViewPatterns #-} - --- | Update YAML preserving top-level key order, blank lines and comments. --- --- The call sequence is mkRaw, encodeInOrder, redress and unmkRaw but if you --- don't care about preserving trailing blank lines this can be simplified to --- encodeInOrder and redress. --- --- Use yamlLines to transform 'RawYaml' to ['RawYamlLine']. -module Stack.YamlUpdate - ( encodeInOrder - , redress - , mkRaw - , unmkRaw - , yamlLines - , RawYaml (..) - , RawYamlLine (..) - , YamlKey (..) - ) where - -import Stack.Prelude -import Data.Coerce (coerce) -import qualified Data.List as L -import qualified Data.Yaml as Yaml -import qualified Data.Yaml.Pretty as Yaml -import qualified RIO.Text as T -import qualified RIO.Map as Map - --- | A whole YAML document, may contain line breaks. -newtype RawYaml = RawYaml Text deriving newtype Display --- | One line from a YAML document, shouldn't contain line breaks. -newtype RawYamlLine = RawYamlLine Text --- | A YAML top-level key as in @key: value@. -newtype YamlKey = YamlKey Text deriving newtype (Eq, Display) - --- | The line number of a blank line. -newtype YamlLineBlank = YamlLineBlank Int deriving newtype Display --- | A line number and some content, usually a comment. This can be used with an --- empty comment to carry the line number for a blank line. -newtype YamlLineComment = YamlLineComment (Int, Text) --- | A mapping from the line number after an encoding that strips blank lines --- and comments to a line number of the original document. -newtype YamlLineReindex = YamlLineReindex (Int, Int) - -data YamlLines = - YamlLines - { blanks :: ![YamlLineBlank] - -- ^ The line numbers of blank lines. - , wholeLineComments :: ![YamlLineComment] - -- ^ Comments where # is the first non-space character in that line so - -- that the comment takes up the whole line. Captured with the leading - -- spaces. - , partLineComments :: ![YamlLineComment] - -- ^ Comments that have been appended to a line. - , reindices :: ![YamlLineReindex] - -- ^ Bumps for line numbers that will need to be moved when blank lines - -- and whole line comments are added back in. - } - -data Pegged = - Pegged - { newIndex :: !Int - -- ^ The new line number to put a line of content. - , leading :: ![YamlLineComment] - -- ^ Comments for putting before anything else. - , partComments :: ![YamlLineComment] - -- ^ Comments to be appended to lines. - , spanComments :: ![YamlLineComment] - -- ^ Blank lines and whole line comments from a range to be put back on - -- the same line as they were taken from. - } - --- | Converts raw YAML as 'Text' with line breaks into a list of lines, dropping --- trailing line breaks. -yamlLines :: RawYaml -> [RawYamlLine] -yamlLines x = RawYamlLine <$> T.lines (coerce x) - --- | Puts blank lines and comments from the original lines into the update. -redress :: [RawYamlLine] -> RawYaml -> RawYaml -redress rawLines (RawYaml t) = - let xs = zip [1 ..] (T.lines t) - in RawYaml . T.concat $ - [ - T.unlines . fromMaybe [x] $ do - Pegged{newIndex = i', leading, partComments, spanComments} - <- fetchPegged rawLines (i, j) - - let x' = maybe - x - (\(YamlLineComment (_, c)) -> x <> " " <> dropToComment c) - (L.find ((== i') . commentLineNumber) partComments) - - let cs = x' : (comment <$> spanComments) - - return $ if i /= 1 then cs else (comment <$> leading) ++ cs - - | (i, x) <- xs - | (j, _) <- drop 1 xs ++ [(0, "")] - ] - -fetchPegged :: [RawYamlLine] -> (Int, Int) -> Maybe Pegged -fetchPegged (pegLines -> yl@YamlLines{reindices}) (i, j) = do - let reindex = flip L.lookup (coerce reindices) - - i' <- reindex i - j' <- reindex j - - let (ps, spanned) = fetchInRange yl (\b -> i' <= b && b < j') - - return $ Pegged - { newIndex = i' - , leading = if i /= 1 then [] else snd $ fetchInRange yl (\b -> b < i') - , partComments = ps - , spanComments = spanned - } - -fetchInRange :: YamlLines - -> (Int -> Bool) - -> ([YamlLineComment], [YamlLineComment]) -fetchInRange YamlLines{blanks, wholeLineComments, partLineComments} p = - let lineNumbers = filter p $ coerce blanks - ls = (\line -> YamlLineComment (line, "")) <$> lineNumbers - filterLineNumber = filter (p . commentLineNumber) - cs = filterLineNumber wholeLineComments - ps = filterLineNumber partLineComments - in (ps, L.sortOn commentLineNumber $ ls ++ cs) - --- | 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) - -endSentinel :: Text -endSentinel = - "ED10F56C-562E-4847-A50B-7541C1732A15: 2986F150-E4A0-41D8-AB9C-8BD82FA12DC4" - -mkRaw :: Text -> RawYaml -mkRaw = addSentinels . RawYaml - -unmkRaw :: RawYaml -> Text -unmkRaw = coerce . removeSentinels - --- | This is leaking implementation but adding a sentinel key-value to the end --- of YAML is a cheap way to ensure trailing newlines are not swallowed. -addSentinels :: RawYaml -> RawYaml -addSentinels (RawYaml x) = RawYaml $ x <> endSentinel - -removeSentinels :: RawYaml -> RawYaml -removeSentinels (RawYaml x) = - RawYaml . T.unlines . filter (/= endSentinel) $ T.lines x - -findKeyLine :: [RawYamlLine] -> YamlKey -> Maybe Int -findKeyLine rawLines (YamlKey x) = - join . listToMaybe . take 1 . dropWhile isNothing $ - [ if x `T.isPrefixOf` y then Just i else Nothing - | RawYamlLine y <- rawLines - | i <- [1 ..] - ] - -comment :: YamlLineComment -> Text -comment (YamlLineComment (_, c)) = c - -commentLineNumber :: YamlLineComment -> Int -commentLineNumber (YamlLineComment (c, _)) = c - -instance Display YamlLineComment where - textDisplay (YamlLineComment (i, s)) = - textDisplay . T.pack $ show (i, T.unpack s) - -dropToComment :: Text -> Text -dropToComment = T.dropWhile (/= '#') - --- | Gather enough information about lines to peg line numbers so that blank --- lines and comments can be reinserted later. -pegLines :: [RawYamlLine] -> YamlLines -pegLines rawLines = - let (ls, rs) = partitionEithers - [ if | y == "" -> Left . Left $ YamlLineBlank i - - | "#" `T.isPrefixOf` T.dropWhile (== ' ') y -> - Left . Right $ YamlLineComment (i, y) - - | otherwise -> - if "#" `T.isPrefixOf` dropToComment y - then Right . Left $ YamlLineComment (i, y) - else Right $ Right i - - | RawYamlLine y <- rawLines - | i <- [1 ..] - ] - - (blanks, wholeLineComments) = partitionEithers ls - (partLineComments, contentLines) = partitionEithers rs - indexLines = - L.sort $ contentLines ++ (commentLineNumber <$> partLineComments) - reindex = zipWith (curry YamlLineReindex) [1 ..] indexLines - - in YamlLines blanks wholeLineComments partLineComments reindex diff --git a/stack.cabal b/stack.cabal index 62a7960ee3..b959489402 100644 --- a/stack.cabal +++ b/stack.cabal @@ -212,7 +212,6 @@ library Stack.Unpack Stack.Upgrade Stack.Upload - Stack.YamlUpdate System.Info.ShortPathName System.Permissions System.Process.Pager