{-# LANGUAGE DeriveFunctor         #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings     #-}
{-# LANGUAGE ScopedTypeVariables   #-}
-- | This module provides a 'FieldGrammarParser', one way to parse
-- @.cabal@ -like files.
--
-- Fields can be specified multiple times in the .cabal files.  The order of
-- such entries is important, but the mutual ordering of different fields is
-- not.Also conditional sections are considered after non-conditional data.
-- The example of this silent-commutation quirk is the fact that
--
-- @
-- buildable: True
-- if os(linux)
--   buildable: False
-- @
--
-- and
--
-- @
-- if os(linux)
--   buildable: False
-- buildable: True
-- @
--
-- behave the same! This is the limitation of 'GeneralPackageDescription'
-- structure.
--
-- So we transform the list of fields @['Field' ann]@ into
-- a map of grouped ordinary fields and a list of lists of sections:
-- @'Fields' ann = 'Map' 'FieldName' ['NamelessField' ann]@ and @[['Section' ann]]@.
--
-- We need list of list of sections, because we need to distinguish situations
-- where there are fields in between. For example
--
-- @
-- if flag(bytestring-lt-0_10_4)
--   build-depends: bytestring < 0.10.4
--
-- default-language: Haskell2020
--
-- else
--   build-depends: bytestring >= 0.10.4
--
-- @
--
-- is obviously invalid specification.
--
-- We can parse 'Fields' like we parse @aeson@ objects, yet we use
-- slightly higher-level API, so we can process unspecified fields,
-- to report unknown fields and save custom @x-fields@.
--
module Distribution.FieldGrammar.Parsec (
    ParsecFieldGrammar,
    parseFieldGrammar,
    fieldGrammarKnownFieldList,
    -- * Auxiliary
    Fields,
    NamelessField (..),
    namelessFieldAnn,
    Section (..),
    runFieldParser,
    runFieldParser',
    fieldLinesToStream,
    )  where

import Data.List                   (dropWhileEnd)
import Distribution.Compat.Newtype
import Distribution.Compat.Prelude
import Distribution.Simple.Utils   (fromUTF8BS)
import Prelude ()

import qualified Data.ByteString              as BS
import qualified Data.List.NonEmpty           as NE
import qualified Data.Map.Strict              as Map
import qualified Data.Set                     as Set
import qualified Distribution.Utils.ShortText as ShortText
import qualified Text.Parsec                  as P
import qualified Text.Parsec.Error            as P

import Distribution.CabalSpecVersion
import Distribution.FieldGrammar.Class
import Distribution.Fields.Field
import Distribution.Fields.ParseResult
import Distribution.Parsec
import Distribution.Parsec.FieldLineStream
import Distribution.Parsec.Position        (positionCol, positionRow)

-------------------------------------------------------------------------------
-- Auxiliary types
-------------------------------------------------------------------------------

type Fields ann = Map FieldName [NamelessField ann]

-- | Single field, without name, but with its annotation.
data NamelessField ann = MkNamelessField !ann [FieldLine ann]
  deriving (NamelessField ann -> NamelessField ann -> Bool
forall ann.
Eq ann =>
NamelessField ann -> NamelessField ann -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: NamelessField ann -> NamelessField ann -> Bool
$c/= :: forall ann.
Eq ann =>
NamelessField ann -> NamelessField ann -> Bool
== :: NamelessField ann -> NamelessField ann -> Bool
$c== :: forall ann.
Eq ann =>
NamelessField ann -> NamelessField ann -> Bool
Eq, Int -> NamelessField ann -> ShowS
forall ann. Show ann => Int -> NamelessField ann -> ShowS
forall ann. Show ann => [NamelessField ann] -> ShowS
forall ann. Show ann => NamelessField ann -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [NamelessField ann] -> ShowS
$cshowList :: forall ann. Show ann => [NamelessField ann] -> ShowS
show :: NamelessField ann -> [Char]
$cshow :: forall ann. Show ann => NamelessField ann -> [Char]
showsPrec :: Int -> NamelessField ann -> ShowS
$cshowsPrec :: forall ann. Show ann => Int -> NamelessField ann -> ShowS
Show, forall a b. a -> NamelessField b -> NamelessField a
forall a b. (a -> b) -> NamelessField a -> NamelessField b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: forall a b. a -> NamelessField b -> NamelessField a
$c<$ :: forall a b. a -> NamelessField b -> NamelessField a
fmap :: forall a b. (a -> b) -> NamelessField a -> NamelessField b
$cfmap :: forall a b. (a -> b) -> NamelessField a -> NamelessField b
Functor)

namelessFieldAnn :: NamelessField ann -> ann
namelessFieldAnn :: forall ann. NamelessField ann -> ann
namelessFieldAnn (MkNamelessField ann
ann [FieldLine ann]
_) = ann
ann

-- | The 'Section' constructor of 'Field'.
data Section ann = MkSection !(Name ann) [SectionArg ann] [Field ann]
  deriving (Section ann -> Section ann -> Bool
forall ann. Eq ann => Section ann -> Section ann -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Section ann -> Section ann -> Bool
$c/= :: forall ann. Eq ann => Section ann -> Section ann -> Bool
== :: Section ann -> Section ann -> Bool
$c== :: forall ann. Eq ann => Section ann -> Section ann -> Bool
Eq, Int -> Section ann -> ShowS
forall ann. Show ann => Int -> Section ann -> ShowS
forall ann. Show ann => [Section ann] -> ShowS
forall ann. Show ann => Section ann -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [Section ann] -> ShowS
$cshowList :: forall ann. Show ann => [Section ann] -> ShowS
show :: Section ann -> [Char]
$cshow :: forall ann. Show ann => Section ann -> [Char]
showsPrec :: Int -> Section ann -> ShowS
$cshowsPrec :: forall ann. Show ann => Int -> Section ann -> ShowS
Show, forall a b. a -> Section b -> Section a
forall a b. (a -> b) -> Section a -> Section b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: forall a b. a -> Section b -> Section a
$c<$ :: forall a b. a -> Section b -> Section a
fmap :: forall a b. (a -> b) -> Section a -> Section b
$cfmap :: forall a b. (a -> b) -> Section a -> Section b
Functor)

-------------------------------------------------------------------------------
-- ParsecFieldGrammar
-------------------------------------------------------------------------------

data ParsecFieldGrammar s a = ParsecFG
    { forall s a. ParsecFieldGrammar s a -> Set FieldName
fieldGrammarKnownFields   :: !(Set FieldName)
    , forall s a. ParsecFieldGrammar s a -> Set FieldName
fieldGrammarKnownPrefixes :: !(Set FieldName)
    , forall s a.
ParsecFieldGrammar s a
-> CabalSpecVersion -> Fields Position -> ParseResult a
fieldGrammarParser        :: !(CabalSpecVersion -> Fields Position -> ParseResult a)
    }
  deriving (forall a b. a -> ParsecFieldGrammar s b -> ParsecFieldGrammar s a
forall a b.
(a -> b) -> ParsecFieldGrammar s a -> ParsecFieldGrammar s b
forall s a b. a -> ParsecFieldGrammar s b -> ParsecFieldGrammar s a
forall s a b.
(a -> b) -> ParsecFieldGrammar s a -> ParsecFieldGrammar s b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: forall a b. a -> ParsecFieldGrammar s b -> ParsecFieldGrammar s a
$c<$ :: forall s a b. a -> ParsecFieldGrammar s b -> ParsecFieldGrammar s a
fmap :: forall a b.
(a -> b) -> ParsecFieldGrammar s a -> ParsecFieldGrammar s b
$cfmap :: forall s a b.
(a -> b) -> ParsecFieldGrammar s a -> ParsecFieldGrammar s b
Functor)

parseFieldGrammar :: CabalSpecVersion -> Fields Position -> ParsecFieldGrammar s a -> ParseResult a
parseFieldGrammar :: forall s a.
CabalSpecVersion
-> Fields Position -> ParsecFieldGrammar s a -> ParseResult a
parseFieldGrammar CabalSpecVersion
v Fields Position
fields ParsecFieldGrammar s a
grammar = do
    forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ (forall k a. Map k a -> [(k, a)]
Map.toList (forall k a. (k -> a -> Bool) -> Map k a -> Map k a
Map.filterWithKey forall {p}. FieldName -> p -> Bool
isUnknownField Fields Position
fields)) forall a b. (a -> b) -> a -> b
$ \(FieldName
name, [NamelessField Position]
nfields) ->
        forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ [NamelessField Position]
nfields forall a b. (a -> b) -> a -> b
$ \(MkNamelessField Position
pos [FieldLine Position]
_) ->
            Position -> PWarnType -> [Char] -> ParseResult ()
parseWarning Position
pos PWarnType
PWTUnknownField forall a b. (a -> b) -> a -> b
$ [Char]
"Unknown field: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show FieldName
name
            -- TODO: fields allowed in this section

    -- parse
    forall s a.
ParsecFieldGrammar s a
-> CabalSpecVersion -> Fields Position -> ParseResult a
fieldGrammarParser ParsecFieldGrammar s a
grammar CabalSpecVersion
v Fields Position
fields

  where
    isUnknownField :: FieldName -> p -> Bool
isUnknownField FieldName
k p
_ = Bool -> Bool
not forall a b. (a -> b) -> a -> b
$
        FieldName
k forall a. Ord a => a -> Set a -> Bool
`Set.member` forall s a. ParsecFieldGrammar s a -> Set FieldName
fieldGrammarKnownFields ParsecFieldGrammar s a
grammar
        Bool -> Bool -> Bool
|| forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (FieldName -> FieldName -> Bool
`BS.isPrefixOf` FieldName
k) (forall s a. ParsecFieldGrammar s a -> Set FieldName
fieldGrammarKnownPrefixes ParsecFieldGrammar s a
grammar)

fieldGrammarKnownFieldList :: ParsecFieldGrammar s a -> [FieldName]
fieldGrammarKnownFieldList :: forall s a. ParsecFieldGrammar s a -> [FieldName]
fieldGrammarKnownFieldList = forall a. Set a -> [a]
Set.toList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s a. ParsecFieldGrammar s a -> Set FieldName
fieldGrammarKnownFields

instance Applicative (ParsecFieldGrammar s) where
    pure :: forall a. a -> ParsecFieldGrammar s a
pure a
x = forall s a.
Set FieldName
-> Set FieldName
-> (CabalSpecVersion -> Fields Position -> ParseResult a)
-> ParsecFieldGrammar s a
ParsecFG forall a. Monoid a => a
mempty forall a. Monoid a => a
mempty (\CabalSpecVersion
_ Fields Position
_  -> forall (f :: * -> *) a. Applicative f => a -> f a
pure a
x)
    {-# INLINE pure  #-}

    ParsecFG Set FieldName
f Set FieldName
f' CabalSpecVersion -> Fields Position -> ParseResult (a -> b)
f'' <*> :: forall a b.
ParsecFieldGrammar s (a -> b)
-> ParsecFieldGrammar s a -> ParsecFieldGrammar s b
<*> ParsecFG Set FieldName
x Set FieldName
x' CabalSpecVersion -> Fields Position -> ParseResult a
x'' = forall s a.
Set FieldName
-> Set FieldName
-> (CabalSpecVersion -> Fields Position -> ParseResult a)
-> ParsecFieldGrammar s a
ParsecFG
        (forall a. Monoid a => a -> a -> a
mappend Set FieldName
f Set FieldName
x)
        (forall a. Monoid a => a -> a -> a
mappend Set FieldName
f' Set FieldName
x')
        (\CabalSpecVersion
v Fields Position
fields -> CabalSpecVersion -> Fields Position -> ParseResult (a -> b)
f'' CabalSpecVersion
v Fields Position
fields forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> CabalSpecVersion -> Fields Position -> ParseResult a
x'' CabalSpecVersion
v Fields Position
fields)
    {-# INLINE (<*>) #-}

warnMultipleSingularFields :: FieldName -> [NamelessField Position] -> ParseResult ()
warnMultipleSingularFields :: FieldName -> [NamelessField Position] -> ParseResult ()
warnMultipleSingularFields FieldName
_ [] = forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
warnMultipleSingularFields FieldName
fn (NamelessField Position
x : [NamelessField Position]
xs) = do
    let pos :: Position
pos  = forall ann. NamelessField ann -> ann
namelessFieldAnn NamelessField Position
x
        poss :: [Position]
poss = forall a b. (a -> b) -> [a] -> [b]
map forall ann. NamelessField ann -> ann
namelessFieldAnn [NamelessField Position]
xs
    Position -> PWarnType -> [Char] -> ParseResult ()
parseWarning Position
pos PWarnType
PWTMultipleSingularField forall a b. (a -> b) -> a -> b
$
        [Char]
"The field " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> [Char]
show FieldName
fn forall a. Semigroup a => a -> a -> a
<> [Char]
" is specified more than once at positions " forall a. [a] -> [a] -> [a]
++ forall a. [a] -> [[a]] -> [a]
intercalate [Char]
", " (forall a b. (a -> b) -> [a] -> [b]
map Position -> [Char]
showPos (Position
pos forall a. a -> [a] -> [a]
: [Position]
poss))

instance FieldGrammar Parsec ParsecFieldGrammar where
    blurFieldGrammar :: forall a b d.
ALens' a b -> ParsecFieldGrammar b d -> ParsecFieldGrammar a d
blurFieldGrammar ALens' a b
_ (ParsecFG Set FieldName
s Set FieldName
s' CabalSpecVersion -> Fields Position -> ParseResult d
parser) = forall s a.
Set FieldName
-> Set FieldName
-> (CabalSpecVersion -> Fields Position -> ParseResult a)
-> ParsecFieldGrammar s a
ParsecFG Set FieldName
s Set FieldName
s' CabalSpecVersion -> Fields Position -> ParseResult d
parser

    uniqueFieldAla :: forall b a s.
(Parsec b, Newtype a b) =>
FieldName -> (a -> b) -> ALens' s a -> ParsecFieldGrammar s a
uniqueFieldAla FieldName
fn a -> b
_pack ALens' s a
_extract = forall s a.
Set FieldName
-> Set FieldName
-> (CabalSpecVersion -> Fields Position -> ParseResult a)
-> ParsecFieldGrammar s a
ParsecFG (forall a. a -> Set a
Set.singleton FieldName
fn) forall a. Set a
Set.empty CabalSpecVersion -> Fields Position -> ParseResult a
parser
      where
        parser :: CabalSpecVersion -> Fields Position -> ParseResult a
parser CabalSpecVersion
v Fields Position
fields = case forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup FieldName
fn Fields Position
fields of
            Maybe [NamelessField Position]
Nothing          -> forall a. Position -> [Char] -> ParseResult a
parseFatalFailure Position
zeroPos forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> [Char]
show FieldName
fn forall a. [a] -> [a] -> [a]
++ [Char]
" field missing"
            Just []          -> forall a. Position -> [Char] -> ParseResult a
parseFatalFailure Position
zeroPos forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> [Char]
show FieldName
fn forall a. [a] -> [a] -> [a]
++ [Char]
" field missing"
            Just [NamelessField Position
x]         -> CabalSpecVersion -> NamelessField Position -> ParseResult a
parseOne CabalSpecVersion
v NamelessField Position
x
            Just xs :: [NamelessField Position]
xs@(NamelessField Position
_:NamelessField Position
y:[NamelessField Position]
ys) -> do
                FieldName -> [NamelessField Position] -> ParseResult ()
warnMultipleSingularFields FieldName
fn [NamelessField Position]
xs
                forall a. NonEmpty a -> a
NE.last forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (CabalSpecVersion -> NamelessField Position -> ParseResult a
parseOne CabalSpecVersion
v) (NamelessField Position
yforall a. a -> [a] -> NonEmpty a
:|[NamelessField Position]
ys)

        parseOne :: CabalSpecVersion -> NamelessField Position -> ParseResult a
parseOne CabalSpecVersion
v (MkNamelessField Position
pos [FieldLine Position]
fls) =
            forall o n. Newtype o n => (o -> n) -> n -> o
unpack' a -> b
_pack forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a.
Position
-> ParsecParser a
-> CabalSpecVersion
-> [FieldLine Position]
-> ParseResult a
runFieldParser Position
pos forall a (m :: * -> *). (Parsec a, CabalParsing m) => m a
parsec CabalSpecVersion
v [FieldLine Position]
fls

    booleanFieldDef :: forall s.
FieldName -> ALens' s Bool -> Bool -> ParsecFieldGrammar s Bool
booleanFieldDef FieldName
fn ALens' s Bool
_extract Bool
def = forall s a.
Set FieldName
-> Set FieldName
-> (CabalSpecVersion -> Fields Position -> ParseResult a)
-> ParsecFieldGrammar s a
ParsecFG (forall a. a -> Set a
Set.singleton FieldName
fn) forall a. Set a
Set.empty CabalSpecVersion -> Fields Position -> ParseResult Bool
parser
      where
        parser :: CabalSpecVersion -> Fields Position -> ParseResult Bool
parser CabalSpecVersion
v Fields Position
fields = case forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup FieldName
fn Fields Position
fields of
            Maybe [NamelessField Position]
Nothing          -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
def
            Just []          -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
def
            Just [NamelessField Position
x]         -> forall {a}.
Parsec a =>
CabalSpecVersion -> NamelessField Position -> ParseResult a
parseOne CabalSpecVersion
v NamelessField Position
x
            Just xs :: [NamelessField Position]
xs@(NamelessField Position
_:NamelessField Position
y:[NamelessField Position]
ys) -> do
                FieldName -> [NamelessField Position] -> ParseResult ()
warnMultipleSingularFields FieldName
fn [NamelessField Position]
xs
                forall a. NonEmpty a -> a
NE.last forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (forall {a}.
Parsec a =>
CabalSpecVersion -> NamelessField Position -> ParseResult a
parseOne CabalSpecVersion
v) (NamelessField Position
yforall a. a -> [a] -> NonEmpty a
:|[NamelessField Position]
ys)

        parseOne :: CabalSpecVersion -> NamelessField Position -> ParseResult a
parseOne CabalSpecVersion
v (MkNamelessField Position
pos [FieldLine Position]
fls) = forall a.
Position
-> ParsecParser a
-> CabalSpecVersion
-> [FieldLine Position]
-> ParseResult a
runFieldParser Position
pos forall a (m :: * -> *). (Parsec a, CabalParsing m) => m a
parsec CabalSpecVersion
v [FieldLine Position]
fls

    optionalFieldAla :: forall b a s.
(Parsec b, Newtype a b) =>
FieldName
-> (a -> b) -> ALens' s (Maybe a) -> ParsecFieldGrammar s (Maybe a)
optionalFieldAla FieldName
fn a -> b
_pack ALens' s (Maybe a)
_extract = forall s a.
Set FieldName
-> Set FieldName
-> (CabalSpecVersion -> Fields Position -> ParseResult a)
-> ParsecFieldGrammar s a
ParsecFG (forall a. a -> Set a
Set.singleton FieldName
fn) forall a. Set a
Set.empty CabalSpecVersion -> Fields Position -> ParseResult (Maybe a)
parser
      where
        parser :: CabalSpecVersion -> Fields Position -> ParseResult (Maybe a)
parser CabalSpecVersion
v Fields Position
fields = case forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup FieldName
fn Fields Position
fields of
            Maybe [NamelessField Position]
Nothing          -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing
            Just []          -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing
            Just [NamelessField Position
x]         -> CabalSpecVersion -> NamelessField Position -> ParseResult (Maybe a)
parseOne CabalSpecVersion
v NamelessField Position
x
            Just xs :: [NamelessField Position]
xs@(NamelessField Position
_:NamelessField Position
y:[NamelessField Position]
ys) -> do
                FieldName -> [NamelessField Position] -> ParseResult ()
warnMultipleSingularFields FieldName
fn [NamelessField Position]
xs
                forall a. NonEmpty a -> a
NE.last forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (CabalSpecVersion -> NamelessField Position -> ParseResult (Maybe a)
parseOne CabalSpecVersion
v) (NamelessField Position
yforall a. a -> [a] -> NonEmpty a
:|[NamelessField Position]
ys)

        parseOne :: CabalSpecVersion -> NamelessField Position -> ParseResult (Maybe a)
parseOne CabalSpecVersion
v (MkNamelessField Position
pos [FieldLine Position]
fls)
            | forall (t :: * -> *) a. Foldable t => t a -> Bool
null [FieldLine Position]
fls  = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing
            | Bool
otherwise = forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall o n. Newtype o n => (o -> n) -> n -> o
unpack' a -> b
_pack forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a.
Position
-> ParsecParser a
-> CabalSpecVersion
-> [FieldLine Position]
-> ParseResult a
runFieldParser Position
pos forall a (m :: * -> *). (Parsec a, CabalParsing m) => m a
parsec CabalSpecVersion
v [FieldLine Position]
fls

    optionalFieldDefAla :: forall b a s.
(Parsec b, Newtype a b, Eq a) =>
FieldName -> (a -> b) -> ALens' s a -> a -> ParsecFieldGrammar s a
optionalFieldDefAla FieldName
fn a -> b
_pack ALens' s a
_extract a
def = forall s a.
Set FieldName
-> Set FieldName
-> (CabalSpecVersion -> Fields Position -> ParseResult a)
-> ParsecFieldGrammar s a
ParsecFG (forall a. a -> Set a
Set.singleton FieldName
fn) forall a. Set a
Set.empty CabalSpecVersion -> Fields Position -> ParseResult a
parser
      where
        parser :: CabalSpecVersion -> Fields Position -> ParseResult a
parser CabalSpecVersion
v Fields Position
fields = case forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup FieldName
fn Fields Position
fields of
            Maybe [NamelessField Position]
Nothing          -> forall (f :: * -> *) a. Applicative f => a -> f a
pure a
def
            Just []          -> forall (f :: * -> *) a. Applicative f => a -> f a
pure a
def
            Just [NamelessField Position
x]         -> CabalSpecVersion -> NamelessField Position -> ParseResult a
parseOne CabalSpecVersion
v NamelessField Position
x
            Just xs :: [NamelessField Position]
xs@(NamelessField Position
_:NamelessField Position
y:[NamelessField Position]
ys) -> do
                FieldName -> [NamelessField Position] -> ParseResult ()
warnMultipleSingularFields FieldName
fn [NamelessField Position]
xs
                forall a. NonEmpty a -> a
NE.last forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (CabalSpecVersion -> NamelessField Position -> ParseResult a
parseOne CabalSpecVersion
v) (NamelessField Position
yforall a. a -> [a] -> NonEmpty a
:|[NamelessField Position]
ys)

        parseOne :: CabalSpecVersion -> NamelessField Position -> ParseResult a
parseOne CabalSpecVersion
v (MkNamelessField Position
pos [FieldLine Position]
fls)
            | forall (t :: * -> *) a. Foldable t => t a -> Bool
null [FieldLine Position]
fls  = forall (f :: * -> *) a. Applicative f => a -> f a
pure a
def
            | Bool
otherwise = forall o n. Newtype o n => (o -> n) -> n -> o
unpack' a -> b
_pack forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a.
Position
-> ParsecParser a
-> CabalSpecVersion
-> [FieldLine Position]
-> ParseResult a
runFieldParser Position
pos forall a (m :: * -> *). (Parsec a, CabalParsing m) => m a
parsec CabalSpecVersion
v [FieldLine Position]
fls

    freeTextField :: forall s.
FieldName
-> ALens' s (Maybe [Char]) -> ParsecFieldGrammar s (Maybe [Char])
freeTextField FieldName
fn ALens' s (Maybe [Char])
_ = forall s a.
Set FieldName
-> Set FieldName
-> (CabalSpecVersion -> Fields Position -> ParseResult a)
-> ParsecFieldGrammar s a
ParsecFG (forall a. a -> Set a
Set.singleton FieldName
fn) forall a. Set a
Set.empty CabalSpecVersion -> Fields Position -> ParseResult (Maybe [Char])
parser where
        parser :: CabalSpecVersion -> Fields Position -> ParseResult (Maybe [Char])
parser CabalSpecVersion
v Fields Position
fields = case forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup FieldName
fn Fields Position
fields of
            Maybe [NamelessField Position]
Nothing          -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing
            Just []          -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing
            Just [NamelessField Position
x]         -> forall {f :: * -> *}.
Applicative f =>
CabalSpecVersion -> NamelessField Position -> f (Maybe [Char])
parseOne CabalSpecVersion
v NamelessField Position
x
            Just xs :: [NamelessField Position]
xs@(NamelessField Position
_:NamelessField Position
y:[NamelessField Position]
ys) -> do
                FieldName -> [NamelessField Position] -> ParseResult ()
warnMultipleSingularFields FieldName
fn [NamelessField Position]
xs
                forall a. NonEmpty a -> a
NE.last forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (forall {f :: * -> *}.
Applicative f =>
CabalSpecVersion -> NamelessField Position -> f (Maybe [Char])
parseOne CabalSpecVersion
v) (NamelessField Position
yforall a. a -> [a] -> NonEmpty a
:|[NamelessField Position]
ys)

        parseOne :: CabalSpecVersion -> NamelessField Position -> f (Maybe [Char])
parseOne CabalSpecVersion
v (MkNamelessField Position
pos [FieldLine Position]
fls)
            | forall (t :: * -> *) a. Foldable t => t a -> Bool
null [FieldLine Position]
fls           = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing
            | CabalSpecVersion
v forall a. Ord a => a -> a -> Bool
>= CabalSpecVersion
CabalSpecV3_0 = forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a. a -> Maybe a
Just (Position -> [FieldLine Position] -> [Char]
fieldlinesToFreeText3 Position
pos [FieldLine Position]
fls))
            | Bool
otherwise          = forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a. a -> Maybe a
Just (forall ann. [FieldLine ann] -> [Char]
fieldlinesToFreeText [FieldLine Position]
fls))

    freeTextFieldDef :: forall s.
FieldName -> ALens' s [Char] -> ParsecFieldGrammar s [Char]
freeTextFieldDef FieldName
fn ALens' s [Char]
_ = forall s a.
Set FieldName
-> Set FieldName
-> (CabalSpecVersion -> Fields Position -> ParseResult a)
-> ParsecFieldGrammar s a
ParsecFG (forall a. a -> Set a
Set.singleton FieldName
fn) forall a. Set a
Set.empty CabalSpecVersion -> Fields Position -> ParseResult [Char]
parser where
        parser :: CabalSpecVersion -> Fields Position -> ParseResult [Char]
parser CabalSpecVersion
v Fields Position
fields = case forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup FieldName
fn Fields Position
fields of
            Maybe [NamelessField Position]
Nothing          -> forall (f :: * -> *) a. Applicative f => a -> f a
pure [Char]
""
            Just []          -> forall (f :: * -> *) a. Applicative f => a -> f a
pure [Char]
""
            Just [NamelessField Position
x]         -> forall {f :: * -> *}.
Applicative f =>
CabalSpecVersion -> NamelessField Position -> f [Char]
parseOne CabalSpecVersion
v NamelessField Position
x
            Just xs :: [NamelessField Position]
xs@(NamelessField Position
_:NamelessField Position
y:[NamelessField Position]
ys) -> do
                FieldName -> [NamelessField Position] -> ParseResult ()
warnMultipleSingularFields FieldName
fn [NamelessField Position]
xs
                forall a. NonEmpty a -> a
NE.last forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (forall {f :: * -> *}.
Applicative f =>
CabalSpecVersion -> NamelessField Position -> f [Char]
parseOne CabalSpecVersion
v) (NamelessField Position
yforall a. a -> [a] -> NonEmpty a
:|[NamelessField Position]
ys)

        parseOne :: CabalSpecVersion -> NamelessField Position -> f [Char]
parseOne CabalSpecVersion
v (MkNamelessField Position
pos [FieldLine Position]
fls)
            | forall (t :: * -> *) a. Foldable t => t a -> Bool
null [FieldLine Position]
fls           = forall (f :: * -> *) a. Applicative f => a -> f a
pure [Char]
""
            | CabalSpecVersion
v forall a. Ord a => a -> a -> Bool
>= CabalSpecVersion
CabalSpecV3_0 = forall (f :: * -> *) a. Applicative f => a -> f a
pure (Position -> [FieldLine Position] -> [Char]
fieldlinesToFreeText3 Position
pos [FieldLine Position]
fls)
            | Bool
otherwise          = forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall ann. [FieldLine ann] -> [Char]
fieldlinesToFreeText [FieldLine Position]
fls)

    -- freeTextFieldDefST = defaultFreeTextFieldDefST
    freeTextFieldDefST :: forall s.
FieldName -> ALens' s ShortText -> ParsecFieldGrammar s ShortText
freeTextFieldDefST FieldName
fn ALens' s ShortText
_ = forall s a.
Set FieldName
-> Set FieldName
-> (CabalSpecVersion -> Fields Position -> ParseResult a)
-> ParsecFieldGrammar s a
ParsecFG (forall a. a -> Set a
Set.singleton FieldName
fn) forall a. Set a
Set.empty CabalSpecVersion -> Fields Position -> ParseResult ShortText
parser where
        parser :: CabalSpecVersion -> Fields Position -> ParseResult ShortText
parser CabalSpecVersion
v Fields Position
fields = case forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup FieldName
fn Fields Position
fields of
            Maybe [NamelessField Position]
Nothing          -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Monoid a => a
mempty
            Just []          -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Monoid a => a
mempty
            Just [NamelessField Position
x]         -> forall {f :: * -> *}.
Applicative f =>
CabalSpecVersion -> NamelessField Position -> f ShortText
parseOne CabalSpecVersion
v NamelessField Position
x
            Just xs :: [NamelessField Position]
xs@(NamelessField Position
_:NamelessField Position
y:[NamelessField Position]
ys) -> do
                FieldName -> [NamelessField Position] -> ParseResult ()
warnMultipleSingularFields FieldName
fn [NamelessField Position]
xs
                forall a. NonEmpty a -> a
NE.last forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (forall {f :: * -> *}.
Applicative f =>
CabalSpecVersion -> NamelessField Position -> f ShortText
parseOne CabalSpecVersion
v) (NamelessField Position
yforall a. a -> [a] -> NonEmpty a
:|[NamelessField Position]
ys)

        parseOne :: CabalSpecVersion -> NamelessField Position -> f ShortText
parseOne CabalSpecVersion
v (MkNamelessField Position
pos [FieldLine Position]
fls) = case [FieldLine Position]
fls of
            []                     -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Monoid a => a
mempty
            [FieldLine Position
_  FieldName
bs]      -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (FieldName -> ShortText
ShortText.unsafeFromUTF8BS FieldName
bs)
            [FieldLine Position]
_ | CabalSpecVersion
v forall a. Ord a => a -> a -> Bool
>= CabalSpecVersion
CabalSpecV3_0 -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Char] -> ShortText
ShortText.toShortText forall a b. (a -> b) -> a -> b
$ Position -> [FieldLine Position] -> [Char]
fieldlinesToFreeText3 Position
pos [FieldLine Position]
fls)
              | Bool
otherwise          -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Char] -> ShortText
ShortText.toShortText forall a b. (a -> b) -> a -> b
$ forall ann. [FieldLine ann] -> [Char]
fieldlinesToFreeText [FieldLine Position]
fls)

    monoidalFieldAla :: forall b a s.
(Parsec b, Monoid a, Newtype a b) =>
FieldName -> (a -> b) -> ALens' s a -> ParsecFieldGrammar s a
monoidalFieldAla FieldName
fn a -> b
_pack ALens' s a
_extract = forall s a.
Set FieldName
-> Set FieldName
-> (CabalSpecVersion -> Fields Position -> ParseResult a)
-> ParsecFieldGrammar s a
ParsecFG (forall a. a -> Set a
Set.singleton FieldName
fn) forall a. Set a
Set.empty forall {t :: * -> *}.
Traversable t =>
CabalSpecVersion
-> Map FieldName (t (NamelessField Position)) -> ParseResult a
parser
      where
        parser :: CabalSpecVersion
-> Map FieldName (t (NamelessField Position)) -> ParseResult a
parser CabalSpecVersion
v Map FieldName (t (NamelessField Position))
fields = case forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup FieldName
fn Map FieldName (t (NamelessField Position))
fields of
            Maybe (t (NamelessField Position))
Nothing -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Monoid a => a
mempty
            Just t (NamelessField Position)
xs -> forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (forall o n. Newtype o n => (o -> n) -> n -> o
unpack' a -> b
_pack) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (forall {a}.
Parsec a =>
CabalSpecVersion -> NamelessField Position -> ParseResult a
parseOne CabalSpecVersion
v) t (NamelessField Position)
xs

        parseOne :: CabalSpecVersion -> NamelessField Position -> ParseResult a
parseOne CabalSpecVersion
v (MkNamelessField Position
pos [FieldLine Position]
fls) = forall a.
Position
-> ParsecParser a
-> CabalSpecVersion
-> [FieldLine Position]
-> ParseResult a
runFieldParser Position
pos forall a (m :: * -> *). (Parsec a, CabalParsing m) => m a
parsec CabalSpecVersion
v [FieldLine Position]
fls

    prefixedFields :: forall s.
FieldName
-> ALens' s [([Char], [Char])]
-> ParsecFieldGrammar s [([Char], [Char])]
prefixedFields FieldName
fnPfx ALens' s [([Char], [Char])]
_extract = forall s a.
Set FieldName
-> Set FieldName
-> (CabalSpecVersion -> Fields Position -> ParseResult a)
-> ParsecFieldGrammar s a
ParsecFG forall a. Monoid a => a
mempty (forall a. a -> Set a
Set.singleton FieldName
fnPfx) (\CabalSpecVersion
_ Fields Position
fs -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (Fields Position -> [([Char], [Char])]
parser Fields Position
fs))
      where
        parser :: Fields Position -> [(String, String)]
        parser :: Fields Position -> [([Char], [Char])]
parser Fields Position
values = forall {b}. [(Position, b)] -> [b]
reorder forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap forall {ann}.
(FieldName, [NamelessField ann]) -> [(ann, ([Char], [Char]))]
convert forall a b. (a -> b) -> a -> b
$ forall a. (a -> Bool) -> [a] -> [a]
filter forall {b}. (FieldName, b) -> Bool
match forall a b. (a -> b) -> a -> b
$ forall k a. Map k a -> [(k, a)]
Map.toList Fields Position
values

        match :: (FieldName, b) -> Bool
match (FieldName
fn, b
_) = FieldName
fnPfx FieldName -> FieldName -> Bool
`BS.isPrefixOf` FieldName
fn
        convert :: (FieldName, [NamelessField ann]) -> [(ann, ([Char], [Char]))]
convert (FieldName
fn, [NamelessField ann]
fields) =
            [ (ann
pos, (FieldName -> [Char]
fromUTF8BS FieldName
fn, ShowS
trim forall a b. (a -> b) -> a -> b
$ FieldName -> [Char]
fromUTF8BS forall a b. (a -> b) -> a -> b
$ forall ann. [FieldLine ann] -> FieldName
fieldlinesToBS [FieldLine ann]
fls))
            | MkNamelessField ann
pos [FieldLine ann]
fls <- [NamelessField ann]
fields
            ]
        -- hack: recover the order of prefixed fields
        reorder :: [(Position, b)] -> [b]
reorder = forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> b
snd forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy (forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing forall a b. (a, b) -> a
fst)
        trim :: String -> String
        trim :: ShowS
trim = forall a. (a -> Bool) -> [a] -> [a]
dropWhile Char -> Bool
isSpace forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> [a] -> [a]
dropWhileEnd Char -> Bool
isSpace

    availableSince :: forall a s.
CabalSpecVersion
-> a -> ParsecFieldGrammar s a -> ParsecFieldGrammar s a
availableSince CabalSpecVersion
vs a
def (ParsecFG Set FieldName
names Set FieldName
prefixes CabalSpecVersion -> Fields Position -> ParseResult a
parser) = forall s a.
Set FieldName
-> Set FieldName
-> (CabalSpecVersion -> Fields Position -> ParseResult a)
-> ParsecFieldGrammar s a
ParsecFG Set FieldName
names Set FieldName
prefixes CabalSpecVersion -> Fields Position -> ParseResult a
parser'
      where
        parser' :: CabalSpecVersion -> Fields Position -> ParseResult a
parser' CabalSpecVersion
v Fields Position
values
            | CabalSpecVersion
v forall a. Ord a => a -> a -> Bool
>= CabalSpecVersion
vs = CabalSpecVersion -> Fields Position -> ParseResult a
parser CabalSpecVersion
v Fields Position
values
            | Bool
otherwise = do
                let unknownFields :: Fields Position
unknownFields = forall k a b. Ord k => Map k a -> Map k b -> Map k a
Map.intersection Fields Position
values forall a b. (a -> b) -> a -> b
$ forall k a. (k -> a) -> Set k -> Map k a
Map.fromSet (forall a b. a -> b -> a
const ()) Set FieldName
names
                forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ (forall k a. Map k a -> [(k, a)]
Map.toList Fields Position
unknownFields) forall a b. (a -> b) -> a -> b
$ \(FieldName
name, [NamelessField Position]
fields) ->
                    forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ [NamelessField Position]
fields forall a b. (a -> b) -> a -> b
$ \(MkNamelessField Position
pos [FieldLine Position]
_) ->
                        Position -> PWarnType -> [Char] -> ParseResult ()
parseWarning Position
pos PWarnType
PWTUnknownField forall a b. (a -> b) -> a -> b
$
                            [Char]
"The field " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> [Char]
show FieldName
name forall a. Semigroup a => a -> a -> a
<> [Char]
" is available only since the Cabal specification version " forall a. [a] -> [a] -> [a]
++ CabalSpecVersion -> [Char]
showCabalSpecVersion CabalSpecVersion
vs forall a. [a] -> [a] -> [a]
++ [Char]
". This field will be ignored."

                forall (f :: * -> *) a. Applicative f => a -> f a
pure a
def

    availableSinceWarn :: forall s a.
CabalSpecVersion
-> ParsecFieldGrammar s a -> ParsecFieldGrammar s a
availableSinceWarn CabalSpecVersion
vs (ParsecFG Set FieldName
names Set FieldName
prefixes CabalSpecVersion -> Fields Position -> ParseResult a
parser) = forall s a.
Set FieldName
-> Set FieldName
-> (CabalSpecVersion -> Fields Position -> ParseResult a)
-> ParsecFieldGrammar s a
ParsecFG Set FieldName
names Set FieldName
prefixes CabalSpecVersion -> Fields Position -> ParseResult a
parser'
      where
        parser' :: CabalSpecVersion -> Fields Position -> ParseResult a
parser' CabalSpecVersion
v Fields Position
values
            | CabalSpecVersion
v forall a. Ord a => a -> a -> Bool
>= CabalSpecVersion
vs = CabalSpecVersion -> Fields Position -> ParseResult a
parser CabalSpecVersion
v Fields Position
values
            | Bool
otherwise = do
                let unknownFields :: Fields Position
unknownFields = forall k a b. Ord k => Map k a -> Map k b -> Map k a
Map.intersection Fields Position
values forall a b. (a -> b) -> a -> b
$ forall k a. (k -> a) -> Set k -> Map k a
Map.fromSet (forall a b. a -> b -> a
const ()) Set FieldName
names
                forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ (forall k a. Map k a -> [(k, a)]
Map.toList Fields Position
unknownFields) forall a b. (a -> b) -> a -> b
$ \(FieldName
name, [NamelessField Position]
fields) ->
                    forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ [NamelessField Position]
fields forall a b. (a -> b) -> a -> b
$ \(MkNamelessField Position
pos [FieldLine Position]
_) ->
                        Position -> PWarnType -> [Char] -> ParseResult ()
parseWarning Position
pos PWarnType
PWTUnknownField forall a b. (a -> b) -> a -> b
$
                            [Char]
"The field " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> [Char]
show FieldName
name forall a. Semigroup a => a -> a -> a
<> [Char]
" is available only since the Cabal specification version " forall a. [a] -> [a] -> [a]
++ CabalSpecVersion -> [Char]
showCabalSpecVersion CabalSpecVersion
vs forall a. [a] -> [a] -> [a]
++ [Char]
"."

                CabalSpecVersion -> Fields Position -> ParseResult a
parser CabalSpecVersion
v Fields Position
values


    -- todo we know about this field
    deprecatedSince :: forall s a.
CabalSpecVersion
-> [Char] -> ParsecFieldGrammar s a -> ParsecFieldGrammar s a
deprecatedSince CabalSpecVersion
vs [Char]
msg (ParsecFG Set FieldName
names Set FieldName
prefixes CabalSpecVersion -> Fields Position -> ParseResult a
parser) = forall s a.
Set FieldName
-> Set FieldName
-> (CabalSpecVersion -> Fields Position -> ParseResult a)
-> ParsecFieldGrammar s a
ParsecFG Set FieldName
names Set FieldName
prefixes CabalSpecVersion -> Fields Position -> ParseResult a
parser'
      where
        parser' :: CabalSpecVersion -> Fields Position -> ParseResult a
parser' CabalSpecVersion
v Fields Position
values
            | CabalSpecVersion
v forall a. Ord a => a -> a -> Bool
>= CabalSpecVersion
vs = do
                let deprecatedFields :: Fields Position
deprecatedFields = forall k a b. Ord k => Map k a -> Map k b -> Map k a
Map.intersection Fields Position
values forall a b. (a -> b) -> a -> b
$ forall k a. (k -> a) -> Set k -> Map k a
Map.fromSet (forall a b. a -> b -> a
const ()) Set FieldName
names
                forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ (forall k a. Map k a -> [(k, a)]
Map.toList Fields Position
deprecatedFields) forall a b. (a -> b) -> a -> b
$ \(FieldName
name, [NamelessField Position]
fields) ->
                    forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ [NamelessField Position]
fields forall a b. (a -> b) -> a -> b
$ \(MkNamelessField Position
pos [FieldLine Position]
_) ->
                        Position -> PWarnType -> [Char] -> ParseResult ()
parseWarning Position
pos PWarnType
PWTDeprecatedField forall a b. (a -> b) -> a -> b
$
                            [Char]
"The field " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> [Char]
show FieldName
name forall a. Semigroup a => a -> a -> a
<> [Char]
" is deprecated in the Cabal specification version " forall a. [a] -> [a] -> [a]
++ CabalSpecVersion -> [Char]
showCabalSpecVersion CabalSpecVersion
vs forall a. [a] -> [a] -> [a]
++ [Char]
". " forall a. [a] -> [a] -> [a]
++ [Char]
msg

                CabalSpecVersion -> Fields Position -> ParseResult a
parser CabalSpecVersion
v Fields Position
values

            | Bool
otherwise = CabalSpecVersion -> Fields Position -> ParseResult a
parser CabalSpecVersion
v Fields Position
values

    removedIn :: forall s a.
CabalSpecVersion
-> [Char] -> ParsecFieldGrammar s a -> ParsecFieldGrammar s a
removedIn CabalSpecVersion
vs [Char]
msg (ParsecFG Set FieldName
names Set FieldName
prefixes CabalSpecVersion -> Fields Position -> ParseResult a
parser) = forall s a.
Set FieldName
-> Set FieldName
-> (CabalSpecVersion -> Fields Position -> ParseResult a)
-> ParsecFieldGrammar s a
ParsecFG Set FieldName
names Set FieldName
prefixes CabalSpecVersion -> Fields Position -> ParseResult a
parser' where
        parser' :: CabalSpecVersion -> Fields Position -> ParseResult a
parser' CabalSpecVersion
v Fields Position
values
            | CabalSpecVersion
v forall a. Ord a => a -> a -> Bool
>= CabalSpecVersion
vs = do
                let msg' :: [Char]
msg' = if forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Char]
msg then [Char]
"" else Char
' ' forall a. a -> [a] -> [a]
: [Char]
msg
                let unknownFields :: Fields Position
unknownFields = forall k a b. Ord k => Map k a -> Map k b -> Map k a
Map.intersection Fields Position
values forall a b. (a -> b) -> a -> b
$ forall k a. (k -> a) -> Set k -> Map k a
Map.fromSet (forall a b. a -> b -> a
const ()) Set FieldName
names
                let namePos :: [(FieldName, Position)]
namePos =
                      [ (FieldName
name, Position
pos)
                      | (FieldName
name, [NamelessField Position]
fields) <- forall k a. Map k a -> [(k, a)]
Map.toList Fields Position
unknownFields
                      , MkNamelessField Position
pos [FieldLine Position]
_ <- [NamelessField Position]
fields
                      ]

                let makeMsg :: a -> [Char]
makeMsg a
name = [Char]
"The field " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> [Char]
show a
name forall a. Semigroup a => a -> a -> a
<> [Char]
" is removed in the Cabal specification version " forall a. [a] -> [a] -> [a]
++ CabalSpecVersion -> [Char]
showCabalSpecVersion CabalSpecVersion
vs forall a. [a] -> [a] -> [a]
++ [Char]
"." forall a. [a] -> [a] -> [a]
++ [Char]
msg'

                case [(FieldName, Position)]
namePos of
                    -- no fields => proceed (with empty values, to be sure)
                    [] -> CabalSpecVersion -> Fields Position -> ParseResult a
parser CabalSpecVersion
v forall a. Monoid a => a
mempty

                    -- if there's single field: fail fatally with it
                    ((FieldName
name, Position
pos) : [(FieldName, Position)]
rest) -> do
                        forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ [(FieldName, Position)]
rest forall a b. (a -> b) -> a -> b
$ \(FieldName
name', Position
pos') -> Position -> [Char] -> ParseResult ()
parseFailure Position
pos' forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> [Char]
makeMsg FieldName
name'
                        forall a. Position -> [Char] -> ParseResult a
parseFatalFailure Position
pos forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> [Char]
makeMsg FieldName
name

              | Bool
otherwise = CabalSpecVersion -> Fields Position -> ParseResult a
parser CabalSpecVersion
v Fields Position
values

    knownField :: forall s. FieldName -> ParsecFieldGrammar s ()
knownField FieldName
fn = forall s a.
Set FieldName
-> Set FieldName
-> (CabalSpecVersion -> Fields Position -> ParseResult a)
-> ParsecFieldGrammar s a
ParsecFG (forall a. a -> Set a
Set.singleton FieldName
fn) forall a. Set a
Set.empty (\CabalSpecVersion
_ Fields Position
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ())

    hiddenField :: forall s a. ParsecFieldGrammar s a -> ParsecFieldGrammar s a
hiddenField = forall a. a -> a
id

-------------------------------------------------------------------------------
-- Parsec
-------------------------------------------------------------------------------

runFieldParser' :: [Position] -> ParsecParser a -> CabalSpecVersion -> FieldLineStream -> ParseResult a
runFieldParser' :: forall a.
[Position]
-> ParsecParser a
-> CabalSpecVersion
-> FieldLineStream
-> ParseResult a
runFieldParser' [Position]
inputPoss ParsecParser a
p CabalSpecVersion
v FieldLineStream
str = case forall s t u a.
Stream s Identity t =>
Parsec s u a -> u -> [Char] -> s -> Either ParseError a
P.runParser ParsecT FieldLineStream [PWarning] Identity (a, [PWarning])
p' [] [Char]
"<field>" FieldLineStream
str of
    Right (a
pok, [PWarning]
ws) -> do
        forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ (\(PWarning PWarnType
t Position
pos [Char]
w) -> Position -> PWarnType -> [Char] -> ParseResult ()
parseWarning (Position -> Position
mapPosition Position
pos) PWarnType
t [Char]
w) [PWarning]
ws
        forall (f :: * -> *) a. Applicative f => a -> f a
pure a
pok
    Left ParseError
err        -> do
        let ppos :: SourcePos
ppos = ParseError -> SourcePos
P.errorPos ParseError
err
        let epos :: Position
epos = Position -> Position
mapPosition forall a b. (a -> b) -> a -> b
$ Int -> Int -> Position
Position (SourcePos -> Int
P.sourceLine SourcePos
ppos) (SourcePos -> Int
P.sourceColumn SourcePos
ppos)

        let msg :: [Char]
msg = [Char]
-> [Char] -> [Char] -> [Char] -> [Char] -> [Message] -> [Char]
P.showErrorMessages
                [Char]
"or" [Char]
"unknown parse error" [Char]
"expecting" [Char]
"unexpected" [Char]
"end of input"
                (ParseError -> [Message]
P.errorMessages ParseError
err)
        forall a. Position -> [Char] -> ParseResult a
parseFatalFailure Position
epos forall a b. (a -> b) -> a -> b
$ [Char]
msg forall a. [a] -> [a] -> [a]
++ [Char]
"\n"
  where
    p' :: ParsecT FieldLineStream [PWarning] Identity (a, [PWarning])
p' = (,) forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m ()
P.spaces forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a.
ParsecParser a
-> CabalSpecVersion -> Parsec FieldLineStream [PWarning] a
unPP ParsecParser a
p CabalSpecVersion
v forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m ()
P.spaces forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* forall s (m :: * -> *) t u.
(Stream s m t, Show t) =>
ParsecT s u m ()
P.eof forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (m :: * -> *) s u. Monad m => ParsecT s u m u
P.getState

    -- Positions start from 1:1, not 0:0
    mapPosition :: Position -> Position
mapPosition (Position Int
prow Int
pcol) = forall {t}. (Ord t, Num t) => t -> [Position] -> Position
go (Int
prow forall a. Num a => a -> a -> a
- Int
1) [Position]
inputPoss where
        go :: t -> [Position] -> Position
go t
_ []                            = Position
zeroPos
        go t
_ [Position Int
row Int
col]            = Int -> Int -> Position
Position Int
row (Int
col forall a. Num a => a -> a -> a
+ Int
pcol forall a. Num a => a -> a -> a
- Int
1)
        go t
n (Position Int
row Int
col:[Position]
_) | t
n forall a. Ord a => a -> a -> Bool
<= t
0 = Int -> Int -> Position
Position Int
row (Int
col forall a. Num a => a -> a -> a
+ Int
pcol forall a. Num a => a -> a -> a
- Int
1)
        go t
n (Position
_:[Position]
ps)                        = t -> [Position] -> Position
go (t
n forall a. Num a => a -> a -> a
- t
1) [Position]
ps

runFieldParser :: Position -> ParsecParser a -> CabalSpecVersion -> [FieldLine Position] -> ParseResult a
runFieldParser :: forall a.
Position
-> ParsecParser a
-> CabalSpecVersion
-> [FieldLine Position]
-> ParseResult a
runFieldParser Position
pp ParsecParser a
p CabalSpecVersion
v [FieldLine Position]
ls = forall a.
[Position]
-> ParsecParser a
-> CabalSpecVersion
-> FieldLineStream
-> ParseResult a
runFieldParser' [Position]
poss ParsecParser a
p CabalSpecVersion
v (forall ann. [FieldLine ann] -> FieldLineStream
fieldLinesToStream [FieldLine Position]
ls)
  where
    poss :: [Position]
poss = forall a b. (a -> b) -> [a] -> [b]
map (\(FieldLine Position
pos FieldName
_) -> Position
pos) [FieldLine Position]
ls forall a. [a] -> [a] -> [a]
++ [Position
pp] -- add "default" position

fieldlinesToBS :: [FieldLine ann] -> BS.ByteString
fieldlinesToBS :: forall ann. [FieldLine ann] -> FieldName
fieldlinesToBS = FieldName -> [FieldName] -> FieldName
BS.intercalate FieldName
"\n" forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map (\(FieldLine ann
_ FieldName
bs) -> FieldName
bs)

-- Example package with dot lines
-- http://hackage.haskell.org/package/copilot-cbmc-0.1/copilot-cbmc.cabal
fieldlinesToFreeText :: [FieldLine ann] -> String
fieldlinesToFreeText :: forall ann. [FieldLine ann] -> [Char]
fieldlinesToFreeText [FieldLine ann
_ FieldName
"."] = [Char]
"."
fieldlinesToFreeText [FieldLine ann]
fls               = forall a. [a] -> [[a]] -> [a]
intercalate [Char]
"\n" (forall a b. (a -> b) -> [a] -> [b]
map forall {ann}. FieldLine ann -> [Char]
go [FieldLine ann]
fls)
  where
    go :: FieldLine ann -> [Char]
go (FieldLine ann
_ FieldName
bs)
        | [Char]
s forall a. Eq a => a -> a -> Bool
== [Char]
"." = [Char]
""
        | Bool
otherwise = [Char]
s
      where
        s :: [Char]
s = ShowS
trim (FieldName -> [Char]
fromUTF8BS FieldName
bs)

        trim :: String -> String
        trim :: ShowS
trim = forall a. (a -> Bool) -> [a] -> [a]
dropWhile Char -> Bool
isSpace forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> [a] -> [a]
dropWhileEnd Char -> Bool
isSpace

fieldlinesToFreeText3 :: Position -> [FieldLine Position] -> String
fieldlinesToFreeText3 :: Position -> [FieldLine Position] -> [Char]
fieldlinesToFreeText3 Position
_   []               = [Char]
""
fieldlinesToFreeText3 Position
_   [FieldLine Position
_ FieldName
bs] = FieldName -> [Char]
fromUTF8BS FieldName
bs
fieldlinesToFreeText3 Position
pos (FieldLine Position
pos1 FieldName
bs1 : fls2 :: [FieldLine Position]
fls2@(FieldLine Position
pos2 FieldName
_ : [FieldLine Position]
_))
    -- if first line is on the same line with field name:
    -- the indentation level is either
    -- 1. the indentation of left most line in rest fields
    -- 2. the indentation of the first line
    -- whichever is leftmost
    | Position -> Int
positionRow Position
pos forall a. Eq a => a -> a -> Bool
== Position -> Int
positionRow Position
pos1 = forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
        forall a b. (a -> b) -> a -> b
$ FieldName -> [Char]
fromUTF8BS FieldName
bs1
        forall a. a -> [a] -> [a]
: forall s a b. (s -> a -> (s, b)) -> s -> [a] -> [b]
mealy (Int -> Position -> FieldLine Position -> (Position, [Char])
mk Int
mcol1) Position
pos1 [FieldLine Position]
fls2

    -- otherwise, also indent the first line
    | Bool
otherwise = forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
        forall a b. (a -> b) -> a -> b
$ forall a. Int -> a -> [a]
replicate (Position -> Int
positionCol Position
pos1 forall a. Num a => a -> a -> a
- Int
mcol2) Char
' '
        forall a. a -> [a] -> [a]
: FieldName -> [Char]
fromUTF8BS FieldName
bs1
        forall a. a -> [a] -> [a]
: forall s a b. (s -> a -> (s, b)) -> s -> [a] -> [b]
mealy (Int -> Position -> FieldLine Position -> (Position, [Char])
mk Int
mcol2) Position
pos1 [FieldLine Position]
fls2

  where
    mcol1 :: Int
mcol1 = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (\Int
a FieldLine Position
b -> forall a. Ord a => a -> a -> a
min Int
a forall a b. (a -> b) -> a -> b
$ Position -> Int
positionCol forall a b. (a -> b) -> a -> b
$ forall ann. FieldLine ann -> ann
fieldLineAnn FieldLine Position
b) (forall a. Ord a => a -> a -> a
min (Position -> Int
positionCol Position
pos1) (Position -> Int
positionCol Position
pos2)) [FieldLine Position]
fls2
    mcol2 :: Int
mcol2 = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (\Int
a FieldLine Position
b -> forall a. Ord a => a -> a -> a
min Int
a forall a b. (a -> b) -> a -> b
$ Position -> Int
positionCol forall a b. (a -> b) -> a -> b
$ forall ann. FieldLine ann -> ann
fieldLineAnn FieldLine Position
b) (Position -> Int
positionCol Position
pos1) [FieldLine Position]
fls2

    mk :: Int -> Position -> FieldLine Position -> (Position, String)
    mk :: Int -> Position -> FieldLine Position -> (Position, [Char])
mk Int
col Position
p (FieldLine Position
q FieldName
bs) =
        ( Position
q
        , forall a. Int -> a -> [a]
replicate Int
newlines Char
'\n'
          forall a. [a] -> [a] -> [a]
++ forall a. Int -> a -> [a]
replicate Int
indent Char
' '
          forall a. [a] -> [a] -> [a]
++ FieldName -> [Char]
fromUTF8BS FieldName
bs
        )
      where
        newlines :: Int
newlines = Position -> Int
positionRow Position
q forall a. Num a => a -> a -> a
- Position -> Int
positionRow Position
p
        indent :: Int
indent   = Position -> Int
positionCol Position
q forall a. Num a => a -> a -> a
- Int
col

mealy :: (s -> a -> (s, b)) -> s -> [a] -> [b]
mealy :: forall s a b. (s -> a -> (s, b)) -> s -> [a] -> [b]
mealy s -> a -> (s, b)
f = s -> [a] -> [b]
go where
    go :: s -> [a] -> [b]
go s
_ [] = []
    go s
s (a
x : [a]
xs) = let ~(s
s', b
y) = s -> a -> (s, b)
f s
s a
x in b
y forall a. a -> [a] -> [a]
: s -> [a] -> [b]
go s
s' [a]
xs

fieldLinesToStream :: [FieldLine ann] -> FieldLineStream
fieldLinesToStream :: forall ann. [FieldLine ann] -> FieldLineStream
fieldLinesToStream []                    = FieldLineStream
fieldLineStreamEnd
fieldLinesToStream [FieldLine ann
_ FieldName
bs]      = FieldName -> FieldLineStream
FLSLast FieldName
bs
fieldLinesToStream (FieldLine ann
_ FieldName
bs : [FieldLine ann]
fs) = FieldName -> FieldLineStream -> FieldLineStream
FLSCons FieldName
bs (forall ann. [FieldLine ann] -> FieldLineStream
fieldLinesToStream [FieldLine ann]
fs)