Cabal-2.4.0.0: Distribution/FieldGrammar.hs

{-# LANGUAGE FlexibleContexts    #-}
{-# LANGUAGE FlexibleInstances   #-}
{-# LANGUAGE ScopedTypeVariables #-}
-- | This module provides a way to specify a grammar of @.cabal@ -like files.
module Distribution.FieldGrammar  (
    -- * Field grammar type
    FieldGrammar (..),
    uniqueField,
    optionalField,
    optionalFieldDef,
    monoidalField,
    deprecatedField',
    -- * Concrete grammar implementations
    ParsecFieldGrammar,
    ParsecFieldGrammar',
    parseFieldGrammar,
    fieldGrammarKnownFieldList,
    PrettyFieldGrammar,
    PrettyFieldGrammar',
    prettyFieldGrammar,
    -- * Auxlilary
    (^^^),
    Section(..),
    Fields,
    partitionFields,
    takeFields,
    runFieldParser,
    runFieldParser',
    )  where

import Distribution.Compat.Prelude
import Prelude ()

import qualified Data.Map.Strict as Map

import Distribution.FieldGrammar.Class
import Distribution.FieldGrammar.Parsec
import Distribution.FieldGrammar.Pretty
import Distribution.Parsec.Field
import Distribution.Utils.Generic (spanMaybe)

type ParsecFieldGrammar' a = ParsecFieldGrammar a a
type PrettyFieldGrammar' a = PrettyFieldGrammar a a

infixl 5 ^^^

-- | Reverse function application which binds tighter than '<$>' and '<*>'.
-- Useful for refining grammar specification.
--
-- @
-- \<*\> 'monoidalFieldAla' "extensions"           (alaList' FSep MQuoted)       oldExtensions
--     ^^^ 'deprecatedSince' [1,12] "Please use 'default-extensions' or 'other-extensions' fields."
-- @
(^^^) :: a -> (a -> b) -> b
x ^^^ f = f x

-- | Partitioning state
data PS ann = PS (Fields ann) [Section ann] [[Section ann]]

-- | Partition field list into field map and groups of sections.
partitionFields :: [Field ann] -> (Fields ann, [[Section ann]])
partitionFields = finalize . foldl' f (PS mempty mempty mempty)
  where
    finalize :: PS ann -> (Fields ann, [[Section ann]])
    finalize (PS fs s ss)
        | null s    = (fs, reverse ss)
        | otherwise = (fs, reverse (reverse s : ss))

    f :: PS ann -> Field ann -> PS ann
    f (PS fs s ss) (Field (Name ann name) fss) =
        PS (Map.insertWith (flip (++)) name [MkNamelessField ann fss] fs) [] ss'
      where
        ss' | null s    = ss
            | otherwise = reverse s : ss
    f (PS fs s ss) (Section name sargs sfields) =
        PS fs (MkSection name sargs sfields : s) ss

-- | Take all fields from the front.
takeFields :: [Field ann] -> (Fields ann, [Field ann])
takeFields = finalize . spanMaybe match
  where
    finalize (fs, rest) = (Map.fromListWith (flip (++)) fs, rest)

    match (Field (Name ann name) fs) = Just (name, [MkNamelessField ann fs])
    match _ = Nothing