cabal-install/src/Distribution/Client/ParseUtils.hs

   1 {-# LANGUAGE ExistentialQuantification #-}
   2 {-# LANGUAGE NamedFieldPuns #-}
   3 {-# LANGUAGE RankNTypes #-}
   4
   5 -----------------------------------------------------------------------------
   6
   7 -----------------------------------------------------------------------------
   8
   9 -- |
  10 -- Module      :  Distribution.Client.ParseUtils
  11 -- Maintainer  :  cabal-devel@haskell.org
  12 -- Portability :  portable
  13 --
  14 -- Parsing utilities.
  15 module Distribution.Client.ParseUtils
  16   ( -- * Fields and field utilities
  17     FieldDescr (..)
  18   , liftField
  19   , liftFields
  20   , addFields
  21   , aliasField
  22   , filterFields
  23   , mapFieldNames
  24   , commandOptionToField
  25   , commandOptionsToFields
  26
  27     -- * Sections and utilities
  28   , SectionDescr (..)
  29   , liftSection
  30
  31     -- * FieldGrammar sections
  32   , FGSectionDescr (..)
  33
  34     -- * Parsing and printing flat config
  35   , parseFields
  36   , ppFields
  37   , ppSection
  38
  39     -- * Parsing and printing config with sections and subsections
  40   , parseFieldsAndSections
  41   , ppFieldsAndSections
  42
  43     -- ** Top level of config files
  44   , parseConfig
  45   , showConfig
  46   )
  47 where
  48
  49 import Distribution.Client.Compat.Prelude hiding (empty, get)
  50 import Prelude ()
  51
  52 import Distribution.Deprecated.ParseUtils
  53   ( Field (..)
  54   , FieldDescr (..)
  55   , LineNo
  56   , ParseResult (..)
  57   , liftField
  58   , lineNo
  59   , readFields
  60   , warning
  61   )
  62 import Distribution.Deprecated.ViewAsFieldDescr
  63   ( viewAsFieldDescr
  64   )
  65
  66 import Distribution.Simple.Command
  67   ( OptionField
  68   )
  69
  70 import qualified Data.ByteString as BS
  71 import qualified Data.Map as Map
  72 import Text.PrettyPrint (($+$))
  73 import qualified Text.PrettyPrint as Disp
  74   ( Doc
  75   , colon
  76   , empty
  77   , isEmpty
  78   , nest
  79   , text
  80   , vcat
  81   , (<>)
  82   )
  83
  84 -- For new parser stuff
  85 import Distribution.CabalSpecVersion (cabalSpecLatest)
  86 import Distribution.FieldGrammar (parseFieldGrammar, partitionFields)
  87 import qualified Distribution.FieldGrammar as FG
  88 import qualified Distribution.Fields as F
  89 import Distribution.Fields.ParseResult (runParseResult)
  90 import Distribution.Parsec.Error (showPError)
  91 import Distribution.Parsec.Position (Position (..))
  92 import Distribution.Parsec.Warning (showPWarning)
  93 import Distribution.Simple.Utils (fromUTF8BS, toUTF8BS)
  94
  95 -------------------------
  96 -- FieldDescr utilities
  97 --
  98
  99 liftFields
 100   :: (b -> a)
 101   -> (a -> b -> b)
 102   -> [FieldDescr a]
 103   -> [FieldDescr b]
 104 liftFields get set = map (liftField get set)
 105
 106 -- | Given a collection of field descriptions, keep only a given list of them,
 107 -- identified by name.
 108 --
 109 -- TODO: This makes it easy to footgun by providing a non-existent field name.
 110 filterFields :: [String] -> [FieldDescr a] -> [FieldDescr a]
 111 filterFields includeFields = filter ((`elem` includeFields) . fieldName)
 112
 113 -- | Given a collection of field descriptions, get a field with a given name.
 114 getField :: String -> [FieldDescr a] -> Maybe (FieldDescr a)
 115 getField name = find ((== name) . fieldName)
 116
 117 -- | Apply a name mangling function to the field names of all the field
 118 -- descriptions. The typical use case is to apply some prefix.
 119 mapFieldNames :: (String -> String) -> [FieldDescr a] -> [FieldDescr a]
 120 mapFieldNames mangleName =
 121   map (\descr -> descr{fieldName = mangleName (fieldName descr)})
 122
 123 -- | Reuse a command line 'OptionField' as a config file 'FieldDescr'.
 124 commandOptionToField :: OptionField a -> FieldDescr a
 125 commandOptionToField = viewAsFieldDescr
 126
 127 -- | Reuse a bunch of command line 'OptionField's as config file 'FieldDescr's.
 128 commandOptionsToFields :: [OptionField a] -> [FieldDescr a]
 129 commandOptionsToFields = map viewAsFieldDescr
 130
 131 -- | Add fields to a field list.
 132 addFields
 133   :: [FieldDescr a]
 134   -> ([FieldDescr a] -> [FieldDescr a])
 135 addFields = (++)
 136
 137 -- | Add a new field which is identical to an existing field but with a
 138 -- different name.
 139 aliasField
 140   :: String
 141   -- ^ The existing field name.
 142   -> String
 143   -- ^ The new field name.
 144   -> [FieldDescr a]
 145   -> [FieldDescr a]
 146 aliasField oldName newName fields =
 147   let fieldToRename = getField oldName fields
 148    in case fieldToRename of
 149         -- TODO: Should this throw?
 150         Nothing -> fields
 151         Just fieldToRename' ->
 152           let newField = fieldToRename'{fieldName = newName}
 153            in newField : fields
 154
 155 ------------------------------------------
 156 -- SectionDescr definition and utilities
 157 --
 158
 159 -- | The description of a section in a config file. It can contain both
 160 -- fields and optionally further subsections. See also 'FieldDescr'.
 161 data SectionDescr a = forall b.
 162   SectionDescr
 163   { sectionName :: String
 164   , sectionFields :: [FieldDescr b]
 165   , sectionSubsections :: [SectionDescr b]
 166   , sectionGet :: a -> [(String, b)]
 167   , sectionSet :: LineNo -> String -> b -> a -> ParseResult a
 168   , sectionEmpty :: b
 169   }
 170
 171 -- | 'FieldGrammar' section description
 172 data FGSectionDescr g a = forall s.
 173   FGSectionDescr
 174   { fgSectionName :: String
 175   , fgSectionGrammar :: g s s
 176   , -- todo: add subsections?
 177     fgSectionGet :: a -> [(String, s)]
 178   , fgSectionSet :: LineNo -> String -> s -> a -> ParseResult a
 179   }
 180
 181 -- | To help construction of config file descriptions in a modular way it is
 182 -- useful to define fields and sections on local types and then hoist them
 183 -- into the parent types when combining them in bigger descriptions.
 184 --
 185 -- This is essentially a lens operation for 'SectionDescr' to help embedding
 186 -- one inside another.
 187 liftSection
 188   :: (b -> a)
 189   -> (a -> b -> b)
 190   -> SectionDescr a
 191   -> SectionDescr b
 192 liftSection get' set' (SectionDescr name fields sections get set empty) =
 193   let sectionGet' = get . get'
 194       sectionSet' lineno param x y = do
 195         x' <- set lineno param x (get' y)
 196         return (set' x' y)
 197    in SectionDescr name fields sections sectionGet' sectionSet' empty
 198
 199 -------------------------------------
 200 -- Parsing and printing flat config
 201 --
 202
 203 -- | Parse a bunch of semi-parsed 'Field's according to a set of field
 204 -- descriptions. It accumulates the result on top of a given initial value.
 205 --
 206 -- This only covers the case of flat configuration without subsections. See
 207 -- also 'parseFieldsAndSections'.
 208 parseFields :: [FieldDescr a] -> a -> [Field] -> ParseResult a
 209 parseFields fieldDescrs =
 210   foldM setField
 211   where
 212     fieldMap = Map.fromList [(fieldName f, f) | f <- fieldDescrs]
 213
 214     setField accum (F line name value) =
 215       case Map.lookup name fieldMap of
 216         Just (FieldDescr _ _ set) -> set line value accum
 217         Nothing -> do
 218           -- the 'world-file' field was removed in 3.8, however
 219           -- it was automatically added to many config files
 220           -- before that, so its warning is silently ignored
 221           unless (name == "world-file") $
 222             warning $
 223               "Unrecognized field " ++ name ++ " on line " ++ show line
 224           return accum
 225     setField accum f = do
 226       warning $ "Unrecognized stanza on line " ++ show (lineNo f)
 227       return accum
 228
 229 -- | This is a customised version of the functions from Distribution.Deprecated.ParseUtils
 230 -- that also optionally print default values for empty fields as comments.
 231 ppFields :: [FieldDescr a] -> (Maybe a) -> a -> Disp.Doc
 232 ppFields fields def cur =
 233   Disp.vcat
 234     [ ppField name (fmap getter def) (getter cur)
 235     | FieldDescr name getter _ <- fields
 236     ]
 237
 238 ppField :: String -> (Maybe Disp.Doc) -> Disp.Doc -> Disp.Doc
 239 ppField name mdef cur
 240   | Disp.isEmpty cur =
 241       maybe
 242         Disp.empty
 243         ( \def ->
 244             Disp.text "--"
 245               <+> Disp.text name
 246                 Disp.<> Disp.colon
 247               <+> def
 248         )
 249         mdef
 250   | otherwise = Disp.text name Disp.<> Disp.colon <+> cur
 251
 252 -- | Pretty print a section.
 253 --
 254 -- Since 'ppFields' does not cover subsections you can use this to add them.
 255 -- Or alternatively use a 'SectionDescr' and use 'ppFieldsAndSections'.
 256 ppSection :: String -> String -> [FieldDescr a] -> (Maybe a) -> a -> Disp.Doc
 257 ppSection name arg fields def cur
 258   | Disp.isEmpty fieldsDoc = Disp.empty
 259   | otherwise =
 260       Disp.text name
 261         <+> argDoc
 262         $+$ (Disp.nest 2 fieldsDoc)
 263   where
 264     fieldsDoc = ppFields fields def cur
 265     argDoc
 266       | arg == "" = Disp.empty
 267       | otherwise = Disp.text arg
 268
 269 -----------------------------------------
 270 -- Parsing and printing non-flat config
 271 --
 272
 273 -- | Much like 'parseFields' but it also allows subsections. The permitted
 274 -- subsections are given by a list of 'SectionDescr's.
 275 parseFieldsAndSections
 276   :: [FieldDescr a]
 277   -- ^ field
 278   -> [SectionDescr a]
 279   -- ^ legacy sections
 280   -> [FGSectionDescr FG.ParsecFieldGrammar a]
 281   -- ^ FieldGrammar sections
 282   -> a
 283   -> [Field]
 284   -> ParseResult a
 285 parseFieldsAndSections fieldDescrs sectionDescrs fgSectionDescrs =
 286   foldM setField
 287   where
 288     fieldMap = Map.fromList [(fieldName f, f) | f <- fieldDescrs]
 289     sectionMap = Map.fromList [(sectionName s, s) | s <- sectionDescrs]
 290     fgSectionMap = Map.fromList [(fgSectionName s, s) | s <- fgSectionDescrs]
 291
 292     setField a (F line name value) =
 293       case Map.lookup name fieldMap of
 294         Just (FieldDescr _ _ set) -> set line value a
 295         Nothing -> do
 296           warning $
 297             "Unrecognized field '"
 298               ++ name
 299               ++ "' on line "
 300               ++ show line
 301           return a
 302     setField a (Section line name param fields) =
 303       case Left <$> Map.lookup name sectionMap <|> Right <$> Map.lookup name fgSectionMap of
 304         Just (Left (SectionDescr _ fieldDescrs' sectionDescrs' _ set sectionEmpty)) -> do
 305           b <- parseFieldsAndSections fieldDescrs' sectionDescrs' [] sectionEmpty fields
 306           set line param b a
 307         Just (Right (FGSectionDescr _ grammar _getter setter)) -> do
 308           let fields1 = map convertField fields
 309               (fields2, sections) = partitionFields fields1
 310           -- TODO: recurse into sections
 311           for_ (concat sections) $ \(FG.MkSection (F.Name (Position line' _) name') _ _) ->
 312             warning $
 313               "Unrecognized section '"
 314                 ++ fromUTF8BS name'
 315                 ++ "' on line "
 316                 ++ show line'
 317           case runParseResult $ parseFieldGrammar cabalSpecLatest fields2 grammar of
 318             (warnings, Right b) -> do
 319               for_ warnings $ \w -> warning $ showPWarning "???" w
 320               setter line param b a
 321             (warnings, Left (_, errs)) -> do
 322               for_ warnings $ \w -> warning $ showPWarning "???" w
 323               case errs of
 324                 err :| _errs -> fail $ showPError "???" err
 325         Nothing -> do
 326           warning $
 327             "Unrecognized section '"
 328               ++ name
 329               ++ "' on line "
 330               ++ show line
 331           return a
 332
 333 convertField :: Field -> F.Field Position
 334 convertField (F line name str) =
 335   F.Field (F.Name pos (toUTF8BS name)) [F.FieldLine pos $ toUTF8BS str]
 336   where
 337     pos = Position line 0
 338 -- arguments omitted
 339 convertField (Section line name _arg fields) =
 340   F.Section (F.Name pos (toUTF8BS name)) [] (map convertField fields)
 341   where
 342     pos = Position line 0
 343
 344 -- | Much like 'ppFields' but also pretty prints any subsections. Subsection
 345 -- are only shown if they are non-empty.
 346 --
 347 -- Note that unlike 'ppFields', at present it does not support printing
 348 -- default values. If needed, adding such support would be quite reasonable.
 349 ppFieldsAndSections :: [FieldDescr a] -> [SectionDescr a] -> [FGSectionDescr FG.PrettyFieldGrammar a] -> a -> Disp.Doc
 350 ppFieldsAndSections fieldDescrs sectionDescrs fgSectionDescrs val =
 351   ppFields fieldDescrs Nothing val
 352     $+$ Disp.vcat
 353       ( [ Disp.text "" $+$ sectionDoc
 354         | SectionDescr
 355             { sectionName
 356             , sectionGet
 357             , sectionFields
 358             , sectionSubsections
 359             } <-
 360             sectionDescrs
 361         , (param, x) <- sectionGet val
 362         , let sectionDoc =
 363                 ppSectionAndSubsections
 364                   sectionName
 365                   param
 366                   sectionFields
 367                   sectionSubsections
 368                   []
 369                   x
 370         , not (Disp.isEmpty sectionDoc)
 371         ]
 372           ++ [ Disp.text "" $+$ sectionDoc
 373              | FGSectionDescr{fgSectionName, fgSectionGrammar, fgSectionGet} <- fgSectionDescrs
 374              , (param, x) <- fgSectionGet val
 375              , let sectionDoc = ppFgSection fgSectionName param fgSectionGrammar x
 376              , not (Disp.isEmpty sectionDoc)
 377              ]
 378       )
 379
 380 -- | Unlike 'ppSection' which has to be called directly, this gets used via
 381 -- 'ppFieldsAndSections' and so does not need to be exported.
 382 ppSectionAndSubsections
 383   :: String
 384   -> String
 385   -> [FieldDescr a]
 386   -> [SectionDescr a]
 387   -> [FGSectionDescr FG.PrettyFieldGrammar a]
 388   -> a
 389   -> Disp.Doc
 390 ppSectionAndSubsections name arg fields sections fgSections cur
 391   | Disp.isEmpty fieldsDoc = Disp.empty
 392   | otherwise =
 393       Disp.text name
 394         <+> argDoc
 395         $+$ (Disp.nest 2 fieldsDoc)
 396   where
 397     fieldsDoc = showConfig fields sections fgSections cur
 398     argDoc
 399       | arg == "" = Disp.empty
 400       | otherwise = Disp.text arg
 401
 402 -- |
 403 --
 404 -- TODO: subsections
 405 -- TODO: this should simply build 'PrettyField'
 406 ppFgSection
 407   :: String
 408   -- ^ section name
 409   -> String
 410   -- ^ parameter
 411   -> FG.PrettyFieldGrammar a a
 412   -> a
 413   -> Disp.Doc
 414 ppFgSection secName arg grammar x
 415   | null prettyFields = Disp.empty
 416   | otherwise =
 417       Disp.text secName
 418         <+> argDoc
 419         $+$ (Disp.nest 2 fieldsDoc)
 420   where
 421     prettyFields = FG.prettyFieldGrammar cabalSpecLatest grammar x
 422
 423     argDoc
 424       | arg == "" = Disp.empty
 425       | otherwise = Disp.text arg
 426
 427     fieldsDoc =
 428       Disp.vcat
 429         [ Disp.text fname' <<>> Disp.colon <<>> doc
 430         | F.PrettyField _ fname doc <- prettyFields -- TODO: this skips sections
 431         , let fname' = fromUTF8BS fname
 432         ]
 433
 434 -----------------------------------------------
 435 -- Top level config file parsing and printing
 436 --
 437
 438 -- | Parse a string in the config file syntax into a value, based on a
 439 -- description of the configuration file in terms of its fields and sections.
 440 --
 441 -- It accumulates the result on top of a given initial (typically empty) value.
 442 parseConfig
 443   :: [FieldDescr a]
 444   -> [SectionDescr a]
 445   -> [FGSectionDescr FG.ParsecFieldGrammar a]
 446   -> a
 447   -> BS.ByteString
 448   -> ParseResult a
 449 parseConfig fieldDescrs sectionDescrs fgSectionDescrs empty str =
 450   parseFieldsAndSections fieldDescrs sectionDescrs fgSectionDescrs empty
 451     =<< readFields str
 452
 453 -- | Render a value in the config file syntax, based on a description of the
 454 -- configuration file in terms of its fields and sections.
 455 showConfig :: [FieldDescr a] -> [SectionDescr a] -> [FGSectionDescr FG.PrettyFieldGrammar a] -> a -> Disp.Doc
 456 showConfig = ppFieldsAndSections