|
| 1 | +{-# LANGUAGE DerivingStrategies #-} |
| 2 | +{-# LANGUAGE GeneralizedNewtypeDeriving #-} |
| 3 | +{-# LANGUAGE MultiWayIf #-} |
| 4 | +{-# LANGUAGE NamedFieldPuns #-} |
| 5 | +{-# LANGUAGE OverloadedStrings #-} |
| 6 | +{-# LANGUAGE ParallelListComp #-} |
| 7 | +{-# LANGUAGE ViewPatterns #-} |
| 8 | + |
| 9 | +-- | Update YAML preserving top-level key order, blank lines and comments. |
| 10 | +-- |
| 11 | +-- The call sequence is mkRaw, encodeInOrder, redress and unmkRaw but if you |
| 12 | +-- don't care about preserving trailing blank lines this can be simplified to |
| 13 | +-- encodeInOrder and redress. |
| 14 | +-- |
| 15 | +-- Use yamlLines to transform 'RawYaml' to ['RawYamlLine']. |
| 16 | +module Stack.YamlUpdate |
| 17 | + ( encodeInOrder |
| 18 | + , redress |
| 19 | + , mkRaw |
| 20 | + , unmkRaw |
| 21 | + , yamlLines |
| 22 | + , RawYaml (..) |
| 23 | + , RawYamlLine (..) |
| 24 | + , YamlKey (..) |
| 25 | + ) where |
| 26 | + |
| 27 | +import Stack.Prelude |
| 28 | +import Data.Coerce (coerce) |
| 29 | +import qualified Data.List as L |
| 30 | +import qualified Data.Yaml as Yaml |
| 31 | +import qualified Data.Yaml.Pretty as Yaml |
| 32 | +import qualified RIO.Text as T |
| 33 | +import qualified RIO.Map as Map |
| 34 | + |
| 35 | +-- | A whole YAML document, may contain line breaks. |
| 36 | +newtype RawYaml = RawYaml Text deriving newtype Display |
| 37 | +-- | One line from a YAML document, shouldn't contain line breaks. |
| 38 | +newtype RawYamlLine = RawYamlLine Text |
| 39 | +-- | A YAML top-level key as in @key: value@. |
| 40 | +newtype YamlKey = YamlKey Text deriving newtype (Eq, Display) |
| 41 | + |
| 42 | +-- | The line number of a blank line. |
| 43 | +newtype YamlLineBlank = YamlLineBlank Int deriving newtype Display |
| 44 | +-- | A line number and some content, usually a comment. This can be used with an |
| 45 | +-- empty comment to carry the line number for a blank line. |
| 46 | +newtype YamlLineComment = YamlLineComment (Int, Text) |
| 47 | +-- | A mapping from the line number after an encoding that strips blank lines |
| 48 | +-- and comments to a line number of the original document. |
| 49 | +newtype YamlLineReindex = YamlLineReindex (Int, Int) |
| 50 | + |
| 51 | +data YamlLines = |
| 52 | + YamlLines |
| 53 | + { blanks :: ![YamlLineBlank] |
| 54 | + -- ^ The line numbers of blank lines. |
| 55 | + , wholeLineComments :: ![YamlLineComment] |
| 56 | + -- ^ Comments where # is the first non-space character in that line so |
| 57 | + -- that the comment takes up the whole line. Captured with the leading |
| 58 | + -- spaces. |
| 59 | + , partLineComments :: ![YamlLineComment] |
| 60 | + -- ^ Comments that have been appended to a line. |
| 61 | + , reindices :: ![YamlLineReindex] |
| 62 | + -- ^ Bumps for line numbers that will need to be moved when blank lines |
| 63 | + -- and whole line comments are added back in. |
| 64 | + } |
| 65 | + |
| 66 | +data Pegged = |
| 67 | + Pegged |
| 68 | + { newIndex :: !Int |
| 69 | + -- ^ The new line number to put a line of content. |
| 70 | + , leading :: ![YamlLineComment] |
| 71 | + -- ^ Comments for putting before anything else. |
| 72 | + , partComments :: ![YamlLineComment] |
| 73 | + -- ^ Comments to be appended to lines. |
| 74 | + , spanComments :: ![YamlLineComment] |
| 75 | + -- ^ Blank lines and whole line comments from a range to be put back on |
| 76 | + -- the same line as they were taken from. |
| 77 | + } |
| 78 | + |
| 79 | +-- | Converts raw YAML as 'Text' with line breaks into a list of lines, dropping |
| 80 | +-- trailing line breaks. |
| 81 | +yamlLines :: RawYaml -> [RawYamlLine] |
| 82 | +yamlLines x = RawYamlLine <$> T.lines (coerce x) |
| 83 | + |
| 84 | +-- | Puts blank lines and comments from the original lines into the update. |
| 85 | +redress :: [RawYamlLine] -> RawYaml -> RawYaml |
| 86 | +redress rawLines (RawYaml t) = |
| 87 | + let xs = zip [1 ..] (T.lines t) |
| 88 | + in RawYaml . T.concat $ |
| 89 | + [ |
| 90 | + T.unlines . fromMaybe [x] $ do |
| 91 | + Pegged{newIndex = i', leading, partComments, spanComments} |
| 92 | + <- fetchPegged rawLines (i, j) |
| 93 | + |
| 94 | + let x' = maybe |
| 95 | + x |
| 96 | + (\(YamlLineComment (_, c)) -> x <> " " <> dropToComment c) |
| 97 | + (L.find ((== i') . commentLineNumber) partComments) |
| 98 | + |
| 99 | + let cs = x' : (comment <$> spanComments) |
| 100 | + |
| 101 | + return $ if i /= 1 then cs else (comment <$> leading) ++ cs |
| 102 | + |
| 103 | + | (i, x) <- xs |
| 104 | + | (j, _) <- drop 1 xs ++ [(0, "")] |
| 105 | + ] |
| 106 | + |
| 107 | +fetchPegged :: [RawYamlLine] -> (Int, Int) -> Maybe Pegged |
| 108 | +fetchPegged (pegLines -> yl@YamlLines{reindices}) (i, j) = do |
| 109 | + let reindex = flip L.lookup (coerce reindices) |
| 110 | + |
| 111 | + i' <- reindex i |
| 112 | + j' <- reindex j |
| 113 | + |
| 114 | + let (ps, spanned) = fetchInRange yl (\b -> i' <= b && b < j') |
| 115 | + |
| 116 | + return $ Pegged |
| 117 | + { newIndex = i' |
| 118 | + , leading = if i /= 1 then [] else snd $ fetchInRange yl (\b -> b < i') |
| 119 | + , partComments = ps |
| 120 | + , spanComments = spanned |
| 121 | + } |
| 122 | + |
| 123 | +fetchInRange :: YamlLines |
| 124 | + -> (Int -> Bool) |
| 125 | + -> ([YamlLineComment], [YamlLineComment]) |
| 126 | +fetchInRange YamlLines{blanks, wholeLineComments, partLineComments} p = |
| 127 | + let lineNumbers = filter p $ coerce blanks |
| 128 | + ls = (\line -> YamlLineComment (line, "")) <$> lineNumbers |
| 129 | + filterLineNumber = filter (p . commentLineNumber) |
| 130 | + cs = filterLineNumber wholeLineComments |
| 131 | + ps = filterLineNumber partLineComments |
| 132 | + in (ps, L.sortOn commentLineNumber $ ls ++ cs) |
| 133 | + |
| 134 | +-- | Uses the order of the keys in the original to preserve the order in the |
| 135 | +-- update except that inserting a key orders it last. |
| 136 | +encodeInOrder :: [RawYamlLine] |
| 137 | + -> [YamlKey] |
| 138 | + -> YamlKey |
| 139 | + -> Yaml.Object |
| 140 | + -> Either UnicodeException RawYaml |
| 141 | +encodeInOrder rawLines keysFound upsertKey@(YamlKey k) yObject = |
| 142 | + let keyLine = findKeyLine rawLines |
| 143 | + ixMap = Map.fromList $ (\yk@(YamlKey x) -> (x, keyLine yk)) <$> keysFound |
| 144 | + preservingCompare x y = |
| 145 | + -- If updating then preserve order but if inserting then put last. |
| 146 | + if | upsertKey `L.elem` keysFound -> |
| 147 | + Map.lookup x ixMap `compare` Map.lookup y ixMap |
| 148 | + | k == x, k == y -> EQ |
| 149 | + | k == x -> GT |
| 150 | + | k == y -> LT |
| 151 | + | otherwise -> Map.lookup x ixMap `compare` Map.lookup y ixMap |
| 152 | + |
| 153 | + keyCmp = Yaml.setConfCompare preservingCompare Yaml.defConfig |
| 154 | + |
| 155 | + in RawYaml <$> decodeUtf8' (Yaml.encodePretty keyCmp yObject) |
| 156 | + |
| 157 | +endSentinel :: Text |
| 158 | +endSentinel = |
| 159 | + "ED10F56C-562E-4847-A50B-7541C1732A15: 2986F150-E4A0-41D8-AB9C-8BD82FA12DC4" |
| 160 | + |
| 161 | +mkRaw :: Text -> RawYaml |
| 162 | +mkRaw = addSentinels . RawYaml |
| 163 | + |
| 164 | +unmkRaw :: RawYaml -> Text |
| 165 | +unmkRaw = coerce . removeSentinels |
| 166 | + |
| 167 | +-- | This is leaking implementation but adding a sentinal key-value to the end |
| 168 | +-- of YAML is a cheap way to ensure trailing newlines are not swallowed. |
| 169 | +addSentinels :: RawYaml -> RawYaml |
| 170 | +addSentinels (RawYaml x) = RawYaml $ x <> endSentinel |
| 171 | + |
| 172 | +removeSentinels :: RawYaml -> RawYaml |
| 173 | +removeSentinels (RawYaml x) = |
| 174 | + RawYaml . T.unlines . filter (/= endSentinel) $ T.lines x |
| 175 | + |
| 176 | +findKeyLine :: [RawYamlLine] -> YamlKey -> Maybe Int |
| 177 | +findKeyLine rawLines (YamlKey x) = |
| 178 | + join . listToMaybe . take 1 . dropWhile isNothing $ |
| 179 | + [ if x `T.isPrefixOf` y then Just i else Nothing |
| 180 | + | RawYamlLine y <- rawLines |
| 181 | + | i <- [1 ..] |
| 182 | + ] |
| 183 | + |
| 184 | +comment :: YamlLineComment -> Text |
| 185 | +comment (YamlLineComment (_, c)) = c |
| 186 | + |
| 187 | +commentLineNumber :: YamlLineComment -> Int |
| 188 | +commentLineNumber (YamlLineComment (c, _)) = c |
| 189 | + |
| 190 | +instance Display YamlLineComment where |
| 191 | + textDisplay (YamlLineComment (i, s)) = |
| 192 | + textDisplay . T.pack $ show (i, T.unpack s) |
| 193 | + |
| 194 | +dropToComment :: Text -> Text |
| 195 | +dropToComment = T.dropWhile (/= '#') |
| 196 | + |
| 197 | +-- | Gather enough information about lines to peg line numbers so that blank |
| 198 | +-- lines and comments can be reinserted later. |
| 199 | +pegLines :: [RawYamlLine] -> YamlLines |
| 200 | +pegLines rawLines = |
| 201 | + let (ls, rs) = partitionEithers |
| 202 | + [ if | y == "" -> Left . Left $ YamlLineBlank i |
| 203 | + |
| 204 | + | "#" `T.isPrefixOf` T.dropWhile (== ' ') y -> |
| 205 | + Left . Right $ YamlLineComment (i, y) |
| 206 | + |
| 207 | + | otherwise -> |
| 208 | + if "#" `T.isPrefixOf` dropToComment y |
| 209 | + then Right . Left $ YamlLineComment (i, y) |
| 210 | + else Right $ Right i |
| 211 | + |
| 212 | + | RawYamlLine y <- rawLines |
| 213 | + | i <- [1 ..] |
| 214 | + ] |
| 215 | + |
| 216 | + (blanks, wholeLineComments) = partitionEithers ls |
| 217 | + (partLineComments, contentLines) = partitionEithers rs |
| 218 | + indexLines = |
| 219 | + L.sort $ contentLines ++ (commentLineNumber <$> partLineComments) |
| 220 | + reindex = zipWith (curry YamlLineReindex) [1 ..] indexLines |
| 221 | + |
| 222 | + in YamlLines blanks wholeLineComments partLineComments reindex |
0 commit comments