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

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