{-# 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,
    -- * Concrete grammar implementations
    ParsecFieldGrammar,
    ParsecFieldGrammar',
    parseFieldGrammar,
    fieldGrammarKnownFieldList,
    PrettyFieldGrammar,
    PrettyFieldGrammar',
    prettyFieldGrammar,
    -- * Auxlilary
    (^^^),
    Section(..),
    Fields,
    partitionFields,
    takeFields,
    runFieldParser,
    runFieldParser',
    defaultFreeTextFieldDefST,
    )  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.Fields.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
a
x ^^^ :: a -> (a -> b) -> b
^^^ a -> b
f = a -> b
f a
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 :: [Field ann] -> (Fields ann, [[Section ann]])
partitionFields = PS ann -> (Fields ann, [[Section ann]])
forall ann. PS ann -> (Fields ann, [[Section ann]])
finalize (PS ann -> (Fields ann, [[Section ann]]))
-> ([Field ann] -> PS ann)
-> [Field ann]
-> (Fields ann, [[Section ann]])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (PS ann -> Field ann -> PS ann) -> PS ann -> [Field ann] -> PS ann
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' PS ann -> Field ann -> PS ann
forall ann. PS ann -> Field ann -> PS ann
f (Fields ann -> [Section ann] -> [[Section ann]] -> PS ann
forall ann.
Fields ann -> [Section ann] -> [[Section ann]] -> PS ann
PS Fields ann
forall a. Monoid a => a
mempty [Section ann]
forall a. Monoid a => a
mempty [[Section ann]]
forall a. Monoid a => a
mempty)
  where
    finalize :: PS ann -> (Fields ann, [[Section ann]])
    finalize :: PS ann -> (Fields ann, [[Section ann]])
finalize (PS Fields ann
fs [Section ann]
s [[Section ann]]
ss)
        | [Section ann] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Section ann]
s    = (Fields ann
fs, [[Section ann]] -> [[Section ann]]
forall a. [a] -> [a]
reverse [[Section ann]]
ss)
        | Bool
otherwise = (Fields ann
fs, [[Section ann]] -> [[Section ann]]
forall a. [a] -> [a]
reverse ([Section ann] -> [Section ann]
forall a. [a] -> [a]
reverse [Section ann]
s [Section ann] -> [[Section ann]] -> [[Section ann]]
forall a. a -> [a] -> [a]
: [[Section ann]]
ss))

    f :: PS ann -> Field ann -> PS ann
    f :: PS ann -> Field ann -> PS ann
f (PS Fields ann
fs [Section ann]
s [[Section ann]]
ss) (Field (Name ann
ann FieldName
name) [FieldLine ann]
fss) =
        Fields ann -> [Section ann] -> [[Section ann]] -> PS ann
forall ann.
Fields ann -> [Section ann] -> [[Section ann]] -> PS ann
PS (([NamelessField ann] -> [NamelessField ann] -> [NamelessField ann])
-> FieldName -> [NamelessField ann] -> Fields ann -> Fields ann
forall k a. Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
Map.insertWith (([NamelessField ann] -> [NamelessField ann] -> [NamelessField ann])
-> [NamelessField ann]
-> [NamelessField ann]
-> [NamelessField ann]
forall a b c. (a -> b -> c) -> b -> a -> c
flip [NamelessField ann] -> [NamelessField ann] -> [NamelessField ann]
forall a. [a] -> [a] -> [a]
(++)) FieldName
name [ann -> [FieldLine ann] -> NamelessField ann
forall ann. ann -> [FieldLine ann] -> NamelessField ann
MkNamelessField ann
ann [FieldLine ann]
fss] Fields ann
fs) [] [[Section ann]]
ss'
      where
        ss' :: [[Section ann]]
ss' | [Section ann] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Section ann]
s    = [[Section ann]]
ss
            | Bool
otherwise = [Section ann] -> [Section ann]
forall a. [a] -> [a]
reverse [Section ann]
s [Section ann] -> [[Section ann]] -> [[Section ann]]
forall a. a -> [a] -> [a]
: [[Section ann]]
ss
    f (PS Fields ann
fs [Section ann]
s [[Section ann]]
ss) (Section Name ann
name [SectionArg ann]
sargs [Field ann]
sfields) =
        Fields ann -> [Section ann] -> [[Section ann]] -> PS ann
forall ann.
Fields ann -> [Section ann] -> [[Section ann]] -> PS ann
PS Fields ann
fs (Name ann -> [SectionArg ann] -> [Field ann] -> Section ann
forall ann.
Name ann -> [SectionArg ann] -> [Field ann] -> Section ann
MkSection Name ann
name [SectionArg ann]
sargs [Field ann]
sfields Section ann -> [Section ann] -> [Section ann]
forall a. a -> [a] -> [a]
: [Section ann]
s) [[Section ann]]
ss

-- | Take all fields from the front.
takeFields :: [Field ann] -> (Fields ann, [Field ann])
takeFields :: [Field ann] -> (Fields ann, [Field ann])
takeFields = ([(FieldName, [NamelessField ann])], [Field ann])
-> (Fields ann, [Field ann])
forall k a b. Ord k => ([(k, [a])], b) -> (Map k [a], b)
finalize (([(FieldName, [NamelessField ann])], [Field ann])
 -> (Fields ann, [Field ann]))
-> ([Field ann]
    -> ([(FieldName, [NamelessField ann])], [Field ann]))
-> [Field ann]
-> (Fields ann, [Field ann])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Field ann -> Maybe (FieldName, [NamelessField ann]))
-> [Field ann] -> ([(FieldName, [NamelessField ann])], [Field ann])
forall a b. (a -> Maybe b) -> [a] -> ([b], [a])
spanMaybe Field ann -> Maybe (FieldName, [NamelessField ann])
forall ann. Field ann -> Maybe (FieldName, [NamelessField ann])
match
  where
    finalize :: ([(k, [a])], b) -> (Map k [a], b)
finalize ([(k, [a])]
fs, b
rest) = (([a] -> [a] -> [a]) -> [(k, [a])] -> Map k [a]
forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
Map.fromListWith (([a] -> [a] -> [a]) -> [a] -> [a] -> [a]
forall a b c. (a -> b -> c) -> b -> a -> c
flip [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
(++)) [(k, [a])]
fs, b
rest)

    match :: Field ann -> Maybe (FieldName, [NamelessField ann])
match (Field (Name ann
ann FieldName
name) [FieldLine ann]
fs) = (FieldName, [NamelessField ann])
-> Maybe (FieldName, [NamelessField ann])
forall a. a -> Maybe a
Just (FieldName
name, [ann -> [FieldLine ann] -> NamelessField ann
forall ann. ann -> [FieldLine ann] -> NamelessField ann
MkNamelessField ann
ann [FieldLine ann]
fs])
    match Field ann
_ = Maybe (FieldName, [NamelessField ann])
forall a. Maybe a
Nothing