@@ -17,10 +17,10 @@ module Stack.ConfigCmd
1717 ,cfgCmdName ) where
1818
1919import Stack.Prelude
20- import Data.Coerce (coerce )
2120import qualified Data.Aeson.Key as Key
2221import qualified Data.Aeson.KeyMap as KeyMap
23- import Data.ByteString.Builder (byteString )
22+ import Data.Attoparsec.Text as P (Parser , parseOnly , skip , skipWhile ,
23+ string , takeText , takeWhile )
2424import qualified Data.Map.Merge.Strict as Map
2525import qualified Data.Text as T
2626import qualified Data.Yaml as Yaml
@@ -37,7 +37,6 @@ import Stack.Constants
3737import Stack.Types.Config
3838import Stack.Types.Resolver
3939import System.Environment (getEnvironment )
40- import Stack.YamlUpdate
4140
4241data ConfigCmdSet
4342 = ConfigCmdSetResolver (Unresolved AbstractResolver )
@@ -73,29 +72,90 @@ cfgCmdSet cmd = do
7372 PCGlobalProject -> liftM (</> stackDotYaml) (getImplicitGlobalProjectDir conf)
7473 PCNoProject _extraDeps -> throwString " config command used when no project configuration available" -- maybe modify the ~/.stack/config.yaml file instead?
7574 CommandScopeGlobal -> return (configUserConfigPath conf)
76- -- We don't need to worry about checking for a valid yaml here
77- rawConfig <- mkRaw <$> liftIO (readFileUtf8 (toFilePath configFilePath))
78- (config :: Yaml. Object<- either throwM return (Yaml. decodeEither' . encodeUtf8 $ coerce rawConfig)
75+ rawConfig <- liftIO (readFileUtf8 (toFilePath configFilePath))
76+ config <- either throwM return (Yaml. decodeEither' $ encodeUtf8 rawConfig)
7977 newValue <- cfgCmdSetValue (parent configFilePath) cmd
80- let cmdKey = cfgCmdSetOptionName cmd
81- config' = KeyMap. insert (Key. fromText cmdKey) newValue config
82- yamlKeys = Key. toText <$> KeyMap. keys config
83- if config' == config
84- then logInfo
85- (fromString (toFilePath configFilePath) <>
86- " already contained the intended configuration and remains \
87- \unchanged." )
88- else do
89- let configLines = yamlLines rawConfig
90- either
91- throwM
92- (\ updated -> do
93- let redressed = unmkRaw $ redress configLines updated
94- writeBinaryFileAtomic configFilePath . byteString $ encodeUtf8 redressed
95-
96- let file = fromString $ toFilePath configFilePath
97- logInfo (file <> " has been updated."
98- (encodeInOrder configLines (coerce yamlKeys) (coerce cmdKey) config')
78+ let yamlLines = T. lines rawConfig
79+ cmdKey = cfgCmdSetOptionName cmd -- Text
80+ cmdKey' = Key. fromText cmdKey -- Data.Aeson.Key.Key
81+ newValue' = T. stripEnd $
82+ decodeUtf8With lenientDecode $ Yaml. encode newValue -- Text
83+ file = toFilePath configFilePath -- String
84+ file' = display $ T. pack file -- Utf8Builder
85+ newYamlLines <- case KeyMap. lookup cmdKey' config of
86+ Nothing -> do
87+ logInfo $ file' <> " has been extended."
88+ pure $ yamlLines <> [cmdKey <> " : " <> newValue']
89+ Just oldValue -> if oldValue == newValue
90+ then do
91+ logInfo $ file' <> " already contained the intended \
92+ \configuration and remains unchanged."
93+ pure yamlLines
94+ else switchLine file' cmdKey newValue' [] yamlLines
95+ liftIO $ writeFileUtf8 file (T. unlines newYamlLines)
96+ where
97+ switchLine file cmdKey _ searched [] = do
98+ logWarn $ display cmdKey <> " not found in YAML file " <> file <>
99+ " as a single line. Multi-line key:value formats are not supported."
100+ pure $ reverse searched
101+ switchLine file cmdKey newValue searched (oldLine: rest) =
102+ case parseOnly (parseLine cmdKey) oldLine of
103+ Left ->
104+ switchLine file cmdKey newValue (oldLine: searched) rest
105+ Right -> do
106+ let newLine = renderKey cmdKey kt <> spaces1 <> " :" <>
107+ spaces2 <> newValue <> comment
108+ logInfo $ file <> " has been updated."
109+ pure $ reverse searched <> (newLine: rest)
110+
111+ -- This assumes that a top-level key will not be indented in the YAML file.
112+ parseLine :: Text -> Parser (KeyType , Text , Text , Text )
113+ parseLine key = do
114+ kt <- parseKey key
115+ spaces1 <- P. takeWhile (== ' '
116+ skip (== ' :'
117+ spaces2 <- P. takeWhile (== ' '
118+ skipWhile (/= ' '
119+ comment <- takeText
120+ pure (kt, spaces1, spaces2, comment)
121+
122+ -- If the key is, for example, install-ghc, this recognises install-ghc,
123+ -- 'install-ghc' or "install-ghc".
124+ parseKey :: Text -> Parser KeyType
125+ parseKey k = parsePlainKey k
126+ <|> parseSingleQuotedKey k
127+ <|> parseDoubleQuotedKey k
128+
129+ parsePlainKey :: Text -> Parser KeyType
130+ parsePlainKey key = do
131+ _ <- string key
132+ pure PlainKey
133+
134+ parseSingleQuotedKey :: Text -> Parser KeyType
135+ parseSingleQuotedKey = parseQuotedKey SingleQuotedKey ' \' '
136+
137+ parseDoubleQuotedKey :: Text -> Parser KeyType
138+ parseDoubleQuotedKey = parseQuotedKey DoubleQuotedKey ' "'
139+
140+ parseQuotedKey :: KeyType -> Char -> Text -> Parser KeyType
141+ parseQuotedKey kt c key = do
142+ skip (== c)
143+ _ <- string key
144+ skip (== c)
145+ pure kt
146+
147+ renderKey :: Text -> KeyType -> Text
148+ renderKey key kt = case kt of
149+ PlainKey -> key
150+ SingleQuotedKey -> ' \' ' `T.cons` key `T.snoc` ' \' '
151+ DoubleQuotedKey -> ' "' `T.cons` key `T.snoc` ' "'
152+
153+ -- | Type representing types of representations of keys in YAML files.
154+ data KeyType
155+ = PlainKey -- ^ For example: install-ghc
156+ | SingleQuotedKey -- ^ For example: 'install-ghc'
157+ | DoubleQuotedKey -- ^ For example: "install-ghc"
158+ deriving (Eq , Show )
99159
100160cfgCmdSetValue
101161 :: (HasConfig env , HasGHCVariant env )
0 commit comments