ParseUtils.hs

{-# LANGUAGE ExistentialQuantification, NamedFieldPuns #-}

-----------------------------------------------------------------------------
-- |
-- Module      :  Distribution.Client.ParseUtils
-- Maintainer  :  cabal-devel@haskell.org
-- Portability :  portable
--
-- Parsing utilities.
-----------------------------------------------------------------------------

module Distribution.Client.ParseUtils (

    -- * Fields and field utilities
    FieldDescr(..),
    liftField,
    liftFields,
    filterFields,
    mapFieldNames,
    commandOptionToField,
    commandOptionsToFields,

    -- * Sections and utilities
    SectionDescr(..),
    liftSection,

    -- * Parsing and printing flat config
    parseFields,
    ppFields,
    ppSection,

    -- * Parsing and printing config with sections and subsections
    parseFieldsAndSections,
    ppFieldsAndSections,

    -- ** Top level of config files
    parseConfig,
    showConfig,
  )
       where

import Distribution.ParseUtils
         ( FieldDescr(..), ParseResult(..), warning, LineNo, lineNo
         , Field(..), liftField, readFieldsFlat )
import Distribution.Simple.Command
         ( OptionField, viewAsFieldDescr )

import Control.Monad    ( foldM )
import Text.PrettyPrint ( (<+>), ($+$) )
import qualified Data.Map as Map
import qualified Text.PrettyPrint as Disp
         ( (<>), Doc, text, colon, vcat, empty, isEmpty, nest )


-------------------------
-- FieldDescr utilities
--

liftFields :: (b -> a)
           -> (a -> b -> b)
           -> [FieldDescr a]
           -> [FieldDescr b]
liftFields get set = map (liftField get set)


-- | Given a collection of field descriptions, keep only a given list of them,
-- identified by name.
--
filterFields :: [String] -> [FieldDescr a] -> [FieldDescr a]
filterFields includeFields = filter ((`elem` includeFields) . fieldName)

-- | Apply a name mangling function to the field names of all the field
-- descriptions. The typical use case is to apply some prefix.
--
mapFieldNames :: (String -> String) -> [FieldDescr a] -> [FieldDescr a]
mapFieldNames mangleName =
    map (\descr -> descr { fieldName = mangleName (fieldName descr) })


-- | Reuse a command line 'OptionField' as a config file 'FieldDescr'.
--
commandOptionToField :: OptionField a -> FieldDescr a
commandOptionToField = viewAsFieldDescr

-- | Reuse a bunch of command line 'OptionField's as config file 'FieldDescr's.
--
commandOptionsToFields :: [OptionField a] -> [FieldDescr a]
commandOptionsToFields = map viewAsFieldDescr


------------------------------------------
-- SectionDescr definition and utilities
--

-- | The description of a section in a config file. It can contain both
-- fields and optionally further subsections. See also 'FieldDescr'.
--
data SectionDescr a = forall b. SectionDescr {
       sectionName        :: String,
       sectionFields      :: [FieldDescr b],
       sectionSubsections :: [SectionDescr b],
       sectionGet         :: a -> [(String, b)],
       sectionSet         :: LineNo -> String -> b -> a -> ParseResult a,
       sectionEmpty       :: b
     }

-- | To help construction of config file descriptions in a modular way it is
-- useful to define fields and sections on local types and then hoist them
-- into the parent types when combining them in bigger descriptions.
--
-- This is essentially a lens operation for 'SectionDescr' to help embedding
-- one inside another.
--
liftSection :: (b -> a)
            -> (a -> b -> b)
            -> SectionDescr a
            -> SectionDescr b
liftSection get' set' (SectionDescr name fields sections get set empty) =
    let sectionGet' = get . get'
        sectionSet' lineno param x y = do
          x' <- set lineno param x (get' y)
          return (set' x' y)
     in SectionDescr name fields sections sectionGet' sectionSet' empty


-------------------------------------
-- Parsing and printing flat config
--

-- | Parse a bunch of semi-parsed 'Field's according to a set of field
-- descriptions. It accumulates the result on top of a given initial value.
--
-- This only covers the case of flat configuration without subsections. See
-- also 'parseFieldsAndSections'.
--
parseFields :: [FieldDescr a] -> a -> [Field] -> ParseResult a
parseFields fieldDescrs =
    foldM setField
  where
    fieldMap = Map.fromList [ (fieldName f, f) | f <- fieldDescrs ]

    setField accum (F line name value) =
      case Map.lookup name fieldMap of
        Just (FieldDescr _ _ set) -> set line value accum
        Nothing -> do
          warning $ "Unrecognized field " ++ name ++ " on line " ++ show line
          return accum

    setField accum f = do
      warning $ "Unrecognized stanza on line " ++ show (lineNo f)
      return accum

-- | This is a customised version of the functions from Distribution.ParseUtils
-- that also optionally print default values for empty fields as comments.
--
ppFields :: [FieldDescr a] -> (Maybe a) -> a -> Disp.Doc
ppFields fields def cur =
    Disp.vcat [ ppField name (fmap getter def) (getter cur)
              | FieldDescr name getter _ <- fields]

ppField :: String -> (Maybe Disp.Doc) -> Disp.Doc -> Disp.Doc
ppField name mdef cur
  | Disp.isEmpty cur = maybe Disp.empty
                       (\def -> Disp.text "--" <+> Disp.text name
                                Disp.<> Disp.colon <+> def) mdef
  | otherwise        = Disp.text name Disp.<> Disp.colon <+> cur

-- | Pretty print a section.
--
-- Since 'ppFields' does not cover subsections you can use this to add them.
-- Or alternatively use a 'SectionDescr' and use 'ppFieldsAndSections'.
--
ppSection :: String -> String -> [FieldDescr a] -> (Maybe a) -> a -> Disp.Doc
ppSection name arg fields def cur
  | Disp.isEmpty fieldsDoc = Disp.empty
  | otherwise              = Disp.text name <+> argDoc
                             $+$ (Disp.nest 2 fieldsDoc)
  where
    fieldsDoc = ppFields fields def cur
    argDoc | arg == "" = Disp.empty
           | otherwise = Disp.text arg


-----------------------------------------
-- Parsing and printing non-flat config
--

-- | Much like 'parseFields' but it also allows subsections. The permitted
-- subsections are given by a list of 'SectionDescr's.
--
parseFieldsAndSections :: [FieldDescr a] -> [SectionDescr a] -> a
                       -> [Field] -> ParseResult a
parseFieldsAndSections fieldDescrs sectionDescrs =
    foldM setField
  where
    fieldMap   = Map.fromList [ (fieldName   f, f) | f <- fieldDescrs   ]
    sectionMap = Map.fromList [ (sectionName s, s) | s <- sectionDescrs ]

    setField a (F line name value) =
      case Map.lookup name fieldMap of
        Just (FieldDescr _ _ set) -> set line value a
        Nothing -> do
          warning $ "Unrecognized field '" ++ name
                 ++ "' on line " ++ show line
          return a

    setField a (Section line name param fields) =
      case Map.lookup name sectionMap of
        Just (SectionDescr _ fieldDescrs' sectionDescrs' _ set sectionEmpty) -> do
          b <- parseFieldsAndSections fieldDescrs' sectionDescrs' sectionEmpty fields
          set line param b a
        Nothing -> do
          warning $ "Unrecognized section '" ++ name
                 ++ "' on line " ++ show line
          return a

    setField accum (block@IfBlock {}) = do
      warning $ "Unrecognized stanza on line " ++ show (lineNo block)
      return accum

-- | Much like 'ppFields' but also pretty prints any subsections. Subsection
-- are only shown if they are non-empty.
--
-- Note that unlike 'ppFields', at present it does not support printing
-- default values. If needed, adding such support would be quite reasonable.
--
ppFieldsAndSections :: [FieldDescr a] -> [SectionDescr a] -> a -> Disp.Doc
ppFieldsAndSections fieldDescrs sectionDescrs val =
    ppFields fieldDescrs Nothing val
      $+$
    Disp.vcat
      [ Disp.text "" $+$ sectionDoc
      | SectionDescr {
          sectionName, sectionGet,
          sectionFields, sectionSubsections
        } <- sectionDescrs
      , (param, x) <- sectionGet val
      , let sectionDoc = ppSectionAndSubsections
                           sectionName param
                           sectionFields sectionSubsections x
      , not (Disp.isEmpty sectionDoc)
      ]

-- | Unlike 'ppSection' which has to be called directly, this gets used via
-- 'ppFieldsAndSections' and so does not need to be exported.
--
ppSectionAndSubsections :: String -> String
                        -> [FieldDescr a] -> [SectionDescr a] -> a -> Disp.Doc
ppSectionAndSubsections name arg fields sections cur
  | Disp.isEmpty fieldsDoc = Disp.empty
  | otherwise              = Disp.text name <+> argDoc
                             $+$ (Disp.nest 2 fieldsDoc)
  where
    fieldsDoc = showConfig fields sections cur
    argDoc | arg == "" = Disp.empty
           | otherwise = Disp.text arg


-----------------------------------------------
-- Top level config file parsing and printing
--

-- | Parse a string in the config file syntax into a value, based on a
-- description of the configuration file in terms of its fields and sections.
--
-- It accumulates the result on top of a given initial (typically empty) value.
--
parseConfig :: [FieldDescr a] -> [SectionDescr a] -> a
            -> String -> ParseResult a
parseConfig fieldDescrs sectionDescrs empty str =
      parseFieldsAndSections fieldDescrs sectionDescrs empty
  =<< readFieldsFlat str

-- | Render a value in the config file syntax, based on a description of the
-- configuration file in terms of its fields and sections.
--
showConfig :: [FieldDescr a] -> [SectionDescr a] -> a -> Disp.Doc
showConfig = ppFieldsAndSections