{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# 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
  , parseFieldGrammarCheckingStanzas
  , fieldGrammarKnownFieldList

    -- * Auxiliary
  , Fields
  , NamelessField (..)
  , namelessFieldAnn
  , Section (..)
  , runFieldParser
  , runFieldParser'
  , fieldLinesToStream
  , freeTextIgnoreDotlineVers
  ) where

import Distribution.Compat.Newtype
import Distribution.Compat.Prelude
import Distribution.Utils.Generic (fromUTF8BS)
import Distribution.Utils.String (trim)
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
(NamelessField ann -> NamelessField ann -> Bool)
-> (NamelessField ann -> NamelessField ann -> Bool)
-> Eq (NamelessField ann)
forall ann.
Eq ann =>
NamelessField ann -> NamelessField ann -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$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
/= :: NamelessField ann -> NamelessField ann -> Bool
Eq, Int -> NamelessField ann -> ShowS
[NamelessField ann] -> ShowS
NamelessField ann -> String
(Int -> NamelessField ann -> ShowS)
-> (NamelessField ann -> String)
-> ([NamelessField ann] -> ShowS)
-> Show (NamelessField ann)
forall ann. Show ann => Int -> NamelessField ann -> ShowS
forall ann. Show ann => [NamelessField ann] -> ShowS
forall ann. Show ann => NamelessField ann -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall ann. Show ann => Int -> NamelessField ann -> ShowS
showsPrec :: Int -> NamelessField ann -> ShowS
$cshow :: forall ann. Show ann => NamelessField ann -> String
show :: NamelessField ann -> String
$cshowList :: forall ann. Show ann => [NamelessField ann] -> ShowS
showList :: [NamelessField ann] -> ShowS
Show, (forall a b. (a -> b) -> NamelessField a -> NamelessField b)
-> (forall a b. a -> NamelessField b -> NamelessField a)
-> Functor NamelessField
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
$cfmap :: forall a b. (a -> b) -> NamelessField a -> NamelessField b
fmap :: forall a b. (a -> b) -> NamelessField a -> NamelessField b
$c<$ :: forall a b. a -> NamelessField b -> NamelessField a
<$ :: forall a b. a -> NamelessField b -> NamelessField a
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
(Section ann -> Section ann -> Bool)
-> (Section ann -> Section ann -> Bool) -> Eq (Section ann)
forall ann. Eq ann => Section ann -> Section ann -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$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
/= :: Section ann -> Section ann -> Bool
Eq, Int -> Section ann -> ShowS
[Section ann] -> ShowS
Section ann -> String
(Int -> Section ann -> ShowS)
-> (Section ann -> String)
-> ([Section ann] -> ShowS)
-> Show (Section ann)
forall ann. Show ann => Int -> Section ann -> ShowS
forall ann. Show ann => [Section ann] -> ShowS
forall ann. Show ann => Section ann -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall ann. Show ann => Int -> Section ann -> ShowS
showsPrec :: Int -> Section ann -> ShowS
$cshow :: forall ann. Show ann => Section ann -> String
show :: Section ann -> String
$cshowList :: forall ann. Show ann => [Section ann] -> ShowS
showList :: [Section ann] -> ShowS
Show, (forall a b. (a -> b) -> Section a -> Section b)
-> (forall a b. a -> Section b -> Section a) -> Functor Section
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
$cfmap :: forall a b. (a -> b) -> Section a -> Section b
fmap :: forall a b. (a -> b) -> Section a -> Section b
$c<$ :: forall a b. a -> Section b -> Section a
<$ :: forall a b. a -> Section b -> Section a
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
-> forall src.
   CabalSpecVersion -> Fields Position -> ParseResult src a
fieldGrammarParser :: forall src. (CabalSpecVersion -> Fields Position -> ParseResult src a)
  }
  deriving ((forall a b.
 (a -> b) -> ParsecFieldGrammar s a -> ParsecFieldGrammar s b)
-> (forall a b.
    a -> ParsecFieldGrammar s b -> ParsecFieldGrammar s a)
-> Functor (ParsecFieldGrammar s)
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
$cfmap :: forall s a b.
(a -> b) -> ParsecFieldGrammar s a -> ParsecFieldGrammar s b
fmap :: forall a b.
(a -> b) -> ParsecFieldGrammar s a -> ParsecFieldGrammar s b
$c<$ :: forall s a b. a -> ParsecFieldGrammar s b -> ParsecFieldGrammar s a
<$ :: forall a b. a -> ParsecFieldGrammar s b -> ParsecFieldGrammar s a
Functor)

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

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

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

-- | Parse a ParsecFieldGrammar and check for fields that should be stanzas.
parseFieldGrammarCheckingStanzas :: CabalSpecVersion -> Fields Position -> ParsecFieldGrammar s a -> Set BS.ByteString -> ParseResult src a
parseFieldGrammarCheckingStanzas :: forall s a src.
CabalSpecVersion
-> Fields Position
-> ParsecFieldGrammar s a
-> Set FieldName
-> ParseResult src a
parseFieldGrammarCheckingStanzas CabalSpecVersion
v Fields Position
fields ParsecFieldGrammar s a
grammar Set FieldName
sections = do
  [(FieldName, [NamelessField Position])]
-> ((FieldName, [NamelessField Position]) -> ParseResult src ())
-> ParseResult src ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ (Fields Position -> [(FieldName, [NamelessField Position])]
forall k a. Map k a -> [(k, a)]
Map.toList ((FieldName -> [NamelessField Position] -> Bool)
-> Fields Position -> Fields Position
forall k a. (k -> a -> Bool) -> Map k a -> Map k a
Map.filterWithKey (ParsecFieldGrammar s a
-> FieldName -> [NamelessField Position] -> Bool
forall s a.
ParsecFieldGrammar s a
-> FieldName -> [NamelessField Position] -> Bool
isUnknownField ParsecFieldGrammar s a
grammar) Fields Position
fields)) (((FieldName, [NamelessField Position]) -> ParseResult src ())
 -> ParseResult src ())
-> ((FieldName, [NamelessField Position]) -> ParseResult src ())
-> ParseResult src ()
forall a b. (a -> b) -> a -> b
$ \(FieldName
name, [NamelessField Position]
nfields) ->
    [NamelessField Position]
-> (NamelessField Position -> ParseResult src ())
-> ParseResult src ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ [NamelessField Position]
nfields ((NamelessField Position -> ParseResult src ())
 -> ParseResult src ())
-> (NamelessField Position -> ParseResult src ())
-> ParseResult src ()
forall a b. (a -> b) -> a -> b
$ \(MkNamelessField Position
pos [FieldLine Position]
_) ->
      if FieldName
name FieldName -> Set FieldName -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set FieldName
sections
        then Position -> String -> ParseResult src ()
forall src. Position -> String -> ParseResult src ()
parseFailure Position
pos (String -> ParseResult src ()) -> String -> ParseResult src ()
forall a b. (a -> b) -> a -> b
$ String
"'" String -> ShowS
forall a. [a] -> [a] -> [a]
++ FieldName -> String
fromUTF8BS FieldName
name String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"' is a stanza, not a field. Remove the trailing ':' to parse a stanza."
        else Position -> PWarnType -> String -> ParseResult src ()
forall src. Position -> PWarnType -> String -> ParseResult src ()
parseWarning Position
pos PWarnType
PWTUnknownField (String -> ParseResult src ()) -> String -> ParseResult src ()
forall a b. (a -> b) -> a -> b
$ String
"Unknown field: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ FieldName -> String
forall a. Show a => a -> String
show FieldName
name
  ParsecFieldGrammar s a
-> forall src.
   CabalSpecVersion -> Fields Position -> ParseResult src a
forall s a.
ParsecFieldGrammar s a
-> forall src.
   CabalSpecVersion -> Fields Position -> ParseResult src a
fieldGrammarParser ParsecFieldGrammar s a
grammar CabalSpecVersion
v Fields Position
fields

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

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

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

warnMultipleSingularFields :: FieldName -> [NamelessField Position] -> ParseResult src ()
warnMultipleSingularFields :: forall src.
FieldName -> [NamelessField Position] -> ParseResult src ()
warnMultipleSingularFields FieldName
_ [] = () -> ParseResult src ()
forall a. a -> ParseResult src a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
warnMultipleSingularFields FieldName
fn (NamelessField Position
x : [NamelessField Position]
xs) = do
  let pos :: Position
pos = NamelessField Position -> Position
forall ann. NamelessField ann -> ann
namelessFieldAnn NamelessField Position
x
      poss :: [Position]
poss = (NamelessField Position -> Position)
-> [NamelessField Position] -> [Position]
forall a b. (a -> b) -> [a] -> [b]
map NamelessField Position -> Position
forall ann. NamelessField ann -> ann
namelessFieldAnn [NamelessField Position]
xs
  Position -> PWarnType -> String -> ParseResult src ()
forall src. Position -> PWarnType -> String -> ParseResult src ()
parseWarning Position
pos PWarnType
PWTMultipleSingularField (String -> ParseResult src ()) -> String -> ParseResult src ()
forall a b. (a -> b) -> a -> b
$
    String
"The field " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> FieldName -> String
forall a. Show a => a -> String
show FieldName
fn String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" is specified more than once at positions " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
", " ((Position -> String) -> [Position] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Position -> String
showPos (Position
pos Position -> [Position] -> [Position]
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' forall src.
CabalSpecVersion -> Fields Position -> ParseResult src d
parser) = Set FieldName
-> Set FieldName
-> (forall src.
    CabalSpecVersion -> Fields Position -> ParseResult src d)
-> ParsecFieldGrammar a d
forall s a.
Set FieldName
-> Set FieldName
-> (forall src.
    CabalSpecVersion -> Fields Position -> ParseResult src a)
-> ParsecFieldGrammar s a
ParsecFG Set FieldName
s Set FieldName
s' CabalSpecVersion -> Fields Position -> ParseResult src d
forall src.
CabalSpecVersion -> Fields Position -> ParseResult src 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 = Set FieldName
-> Set FieldName
-> (forall src.
    CabalSpecVersion -> Fields Position -> ParseResult src a)
-> ParsecFieldGrammar s a
forall s a.
Set FieldName
-> Set FieldName
-> (forall src.
    CabalSpecVersion -> Fields Position -> ParseResult src a)
-> ParsecFieldGrammar s a
ParsecFG (FieldName -> Set FieldName
forall a. a -> Set a
Set.singleton FieldName
fn) Set FieldName
forall a. Set a
Set.empty CabalSpecVersion -> Fields Position -> ParseResult src a
forall src.
CabalSpecVersion -> Fields Position -> ParseResult src a
parser
    where
      parser :: CabalSpecVersion -> Fields Position -> ParseResult src a
parser CabalSpecVersion
v Fields Position
fields = case FieldName -> Fields Position -> Maybe [NamelessField Position]
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup FieldName
fn Fields Position
fields of
        Maybe [NamelessField Position]
Nothing -> Position -> String -> ParseResult src a
forall src a. Position -> String -> ParseResult src a
parseFatalFailure Position
zeroPos (String -> ParseResult src a) -> String -> ParseResult src a
forall a b. (a -> b) -> a -> b
$ FieldName -> String
forall a. Show a => a -> String
show FieldName
fn String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" field missing"
        Just [] -> Position -> String -> ParseResult src a
forall src a. Position -> String -> ParseResult src a
parseFatalFailure Position
zeroPos (String -> ParseResult src a) -> String -> ParseResult src a
forall a b. (a -> b) -> a -> b
$ FieldName -> String
forall a. Show a => a -> String
show FieldName
fn String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" field missing"
        Just [NamelessField Position
x] -> CabalSpecVersion -> NamelessField Position -> ParseResult src a
forall {src}.
CabalSpecVersion -> NamelessField Position -> ParseResult src 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 src ()
forall src.
FieldName -> [NamelessField Position] -> ParseResult src ()
warnMultipleSingularFields FieldName
fn [NamelessField Position]
xs
          NonEmpty a -> a
forall a. NonEmpty a -> a
NE.last (NonEmpty a -> a)
-> ParseResult src (NonEmpty a) -> ParseResult src a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (NamelessField Position -> ParseResult src a)
-> NonEmpty (NamelessField Position)
-> ParseResult src (NonEmpty a)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> NonEmpty a -> f (NonEmpty b)
traverse (CabalSpecVersion -> NamelessField Position -> ParseResult src a
forall {src}.
CabalSpecVersion -> NamelessField Position -> ParseResult src a
parseOne CabalSpecVersion
v) (NamelessField Position
y NamelessField Position
-> [NamelessField Position] -> NonEmpty (NamelessField Position)
forall a. a -> [a] -> NonEmpty a
:| [NamelessField Position]
ys)

      parseOne :: CabalSpecVersion -> NamelessField Position -> ParseResult src a
parseOne CabalSpecVersion
v (MkNamelessField Position
pos [FieldLine Position]
fls) =
        (a -> b) -> b -> a
forall o n. Newtype o n => (o -> n) -> n -> o
unpack' a -> b
_pack (b -> a) -> ParseResult src b -> ParseResult src a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Position
-> ParsecParser b
-> CabalSpecVersion
-> [FieldLine Position]
-> ParseResult src b
forall a src.
Position
-> ParsecParser a
-> CabalSpecVersion
-> [FieldLine Position]
-> ParseResult src a
runFieldParser Position
pos ParsecParser b
forall a (m :: * -> *). (Parsec a, CabalParsing m) => m a
forall (m :: * -> *). CabalParsing m => m b
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 = Set FieldName
-> Set FieldName
-> (forall src.
    CabalSpecVersion -> Fields Position -> ParseResult src Bool)
-> ParsecFieldGrammar s Bool
forall s a.
Set FieldName
-> Set FieldName
-> (forall src.
    CabalSpecVersion -> Fields Position -> ParseResult src a)
-> ParsecFieldGrammar s a
ParsecFG (FieldName -> Set FieldName
forall a. a -> Set a
Set.singleton FieldName
fn) Set FieldName
forall a. Set a
Set.empty CabalSpecVersion -> Fields Position -> ParseResult src Bool
forall src.
CabalSpecVersion -> Fields Position -> ParseResult src Bool
parser
    where
      parser :: CabalSpecVersion -> Fields Position -> ParseResult src Bool
parser CabalSpecVersion
v Fields Position
fields = case FieldName -> Fields Position -> Maybe [NamelessField Position]
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup FieldName
fn Fields Position
fields of
        Maybe [NamelessField Position]
Nothing -> Bool -> ParseResult src Bool
forall a. a -> ParseResult src a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
def
        Just [] -> Bool -> ParseResult src Bool
forall a. a -> ParseResult src a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
def
        Just [NamelessField Position
x] -> CabalSpecVersion -> NamelessField Position -> ParseResult src Bool
forall {a} {src}.
Parsec a =>
CabalSpecVersion -> NamelessField Position -> ParseResult src 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 src ()
forall src.
FieldName -> [NamelessField Position] -> ParseResult src ()
warnMultipleSingularFields FieldName
fn [NamelessField Position]
xs
          NonEmpty Bool -> Bool
forall a. NonEmpty a -> a
NE.last (NonEmpty Bool -> Bool)
-> ParseResult src (NonEmpty Bool) -> ParseResult src Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (NamelessField Position -> ParseResult src Bool)
-> NonEmpty (NamelessField Position)
-> ParseResult src (NonEmpty Bool)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> NonEmpty a -> f (NonEmpty b)
traverse (CabalSpecVersion -> NamelessField Position -> ParseResult src Bool
forall {a} {src}.
Parsec a =>
CabalSpecVersion -> NamelessField Position -> ParseResult src a
parseOne CabalSpecVersion
v) (NamelessField Position
y NamelessField Position
-> [NamelessField Position] -> NonEmpty (NamelessField Position)
forall a. a -> [a] -> NonEmpty a
:| [NamelessField Position]
ys)

      parseOne :: CabalSpecVersion -> NamelessField Position -> ParseResult src a
parseOne CabalSpecVersion
v (MkNamelessField Position
pos [FieldLine Position]
fls) = Position
-> ParsecParser a
-> CabalSpecVersion
-> [FieldLine Position]
-> ParseResult src a
forall a src.
Position
-> ParsecParser a
-> CabalSpecVersion
-> [FieldLine Position]
-> ParseResult src a
runFieldParser Position
pos ParsecParser a
forall a (m :: * -> *). (Parsec a, CabalParsing m) => m a
forall (m :: * -> *). 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 = Set FieldName
-> Set FieldName
-> (forall src.
    CabalSpecVersion -> Fields Position -> ParseResult src (Maybe a))
-> ParsecFieldGrammar s (Maybe a)
forall s a.
Set FieldName
-> Set FieldName
-> (forall src.
    CabalSpecVersion -> Fields Position -> ParseResult src a)
-> ParsecFieldGrammar s a
ParsecFG (FieldName -> Set FieldName
forall a. a -> Set a
Set.singleton FieldName
fn) Set FieldName
forall a. Set a
Set.empty CabalSpecVersion -> Fields Position -> ParseResult src (Maybe a)
forall src.
CabalSpecVersion -> Fields Position -> ParseResult src (Maybe a)
parser
    where
      parser :: CabalSpecVersion -> Fields Position -> ParseResult src (Maybe a)
parser CabalSpecVersion
v Fields Position
fields = case FieldName -> Fields Position -> Maybe [NamelessField Position]
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup FieldName
fn Fields Position
fields of
        Maybe [NamelessField Position]
Nothing -> Maybe a -> ParseResult src (Maybe a)
forall a. a -> ParseResult src a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe a
forall a. Maybe a
Nothing
        Just [] -> Maybe a -> ParseResult src (Maybe a)
forall a. a -> ParseResult src a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe a
forall a. Maybe a
Nothing
        Just [NamelessField Position
x] -> CabalSpecVersion
-> NamelessField Position -> ParseResult src (Maybe a)
forall {src}.
CabalSpecVersion
-> NamelessField Position -> ParseResult src (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 src ()
forall src.
FieldName -> [NamelessField Position] -> ParseResult src ()
warnMultipleSingularFields FieldName
fn [NamelessField Position]
xs
          NonEmpty (Maybe a) -> Maybe a
forall a. NonEmpty a -> a
NE.last (NonEmpty (Maybe a) -> Maybe a)
-> ParseResult src (NonEmpty (Maybe a))
-> ParseResult src (Maybe a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (NamelessField Position -> ParseResult src (Maybe a))
-> NonEmpty (NamelessField Position)
-> ParseResult src (NonEmpty (Maybe a))
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> NonEmpty a -> f (NonEmpty b)
traverse (CabalSpecVersion
-> NamelessField Position -> ParseResult src (Maybe a)
forall {src}.
CabalSpecVersion
-> NamelessField Position -> ParseResult src (Maybe a)
parseOne CabalSpecVersion
v) (NamelessField Position
y NamelessField Position
-> [NamelessField Position] -> NonEmpty (NamelessField Position)
forall a. a -> [a] -> NonEmpty a
:| [NamelessField Position]
ys)

      parseOne :: CabalSpecVersion
-> NamelessField Position -> ParseResult src (Maybe a)
parseOne CabalSpecVersion
v (MkNamelessField Position
pos [FieldLine Position]
fls)
        | [FieldLine Position] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [FieldLine Position]
fls = Maybe a -> ParseResult src (Maybe a)
forall a. a -> ParseResult src a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe a
forall a. Maybe a
Nothing
        | Bool
otherwise = a -> Maybe a
forall a. a -> Maybe a
Just (a -> Maybe a) -> (b -> a) -> b -> Maybe a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> b) -> b -> a
forall o n. Newtype o n => (o -> n) -> n -> o
unpack' a -> b
_pack (b -> Maybe a) -> ParseResult src b -> ParseResult src (Maybe a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Position
-> ParsecParser b
-> CabalSpecVersion
-> [FieldLine Position]
-> ParseResult src b
forall a src.
Position
-> ParsecParser a
-> CabalSpecVersion
-> [FieldLine Position]
-> ParseResult src a
runFieldParser Position
pos ParsecParser b
forall a (m :: * -> *). (Parsec a, CabalParsing m) => m a
forall (m :: * -> *). CabalParsing m => m b
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 = Set FieldName
-> Set FieldName
-> (forall src.
    CabalSpecVersion -> Fields Position -> ParseResult src a)
-> ParsecFieldGrammar s a
forall s a.
Set FieldName
-> Set FieldName
-> (forall src.
    CabalSpecVersion -> Fields Position -> ParseResult src a)
-> ParsecFieldGrammar s a
ParsecFG (FieldName -> Set FieldName
forall a. a -> Set a
Set.singleton FieldName
fn) Set FieldName
forall a. Set a
Set.empty CabalSpecVersion -> Fields Position -> ParseResult src a
forall src.
CabalSpecVersion -> Fields Position -> ParseResult src a
parser
    where
      parser :: CabalSpecVersion -> Fields Position -> ParseResult src a
parser CabalSpecVersion
v Fields Position
fields = case FieldName -> Fields Position -> Maybe [NamelessField Position]
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup FieldName
fn Fields Position
fields of
        Maybe [NamelessField Position]
Nothing -> a -> ParseResult src a
forall a. a -> ParseResult src a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
def
        Just [] -> a -> ParseResult src a
forall a. a -> ParseResult src a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
def
        Just [NamelessField Position
x] -> CabalSpecVersion -> NamelessField Position -> ParseResult src a
forall {src}.
CabalSpecVersion -> NamelessField Position -> ParseResult src 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 src ()
forall src.
FieldName -> [NamelessField Position] -> ParseResult src ()
warnMultipleSingularFields FieldName
fn [NamelessField Position]
xs
          NonEmpty a -> a
forall a. NonEmpty a -> a
NE.last (NonEmpty a -> a)
-> ParseResult src (NonEmpty a) -> ParseResult src a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (NamelessField Position -> ParseResult src a)
-> NonEmpty (NamelessField Position)
-> ParseResult src (NonEmpty a)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> NonEmpty a -> f (NonEmpty b)
traverse (CabalSpecVersion -> NamelessField Position -> ParseResult src a
forall {src}.
CabalSpecVersion -> NamelessField Position -> ParseResult src a
parseOne CabalSpecVersion
v) (NamelessField Position
y NamelessField Position
-> [NamelessField Position] -> NonEmpty (NamelessField Position)
forall a. a -> [a] -> NonEmpty a
:| [NamelessField Position]
ys)

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

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

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

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

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

  -- freeTextFieldDefST = defaultFreeTextFieldDefST
  freeTextFieldDefST :: forall s.
FieldName -> ALens' s ShortText -> ParsecFieldGrammar s ShortText
freeTextFieldDefST FieldName
fn ALens' s ShortText
_ = Set FieldName
-> Set FieldName
-> (forall src.
    CabalSpecVersion -> Fields Position -> ParseResult src ShortText)
-> ParsecFieldGrammar s ShortText
forall s a.
Set FieldName
-> Set FieldName
-> (forall src.
    CabalSpecVersion -> Fields Position -> ParseResult src a)
-> ParsecFieldGrammar s a
ParsecFG (FieldName -> Set FieldName
forall a. a -> Set a
Set.singleton FieldName
fn) Set FieldName
forall a. Set a
Set.empty CabalSpecVersion -> Fields Position -> ParseResult src ShortText
forall src.
CabalSpecVersion -> Fields Position -> ParseResult src ShortText
parser
    where
      parser :: CabalSpecVersion -> Fields Position -> ParseResult src ShortText
parser CabalSpecVersion
v Fields Position
fields = case FieldName -> Fields Position -> Maybe [NamelessField Position]
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup FieldName
fn Fields Position
fields of
        Maybe [NamelessField Position]
Nothing -> ShortText -> ParseResult src ShortText
forall a. a -> ParseResult src a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ShortText
forall a. Monoid a => a
mempty
        Just [] -> ShortText -> ParseResult src ShortText
forall a. a -> ParseResult src a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ShortText
forall a. Monoid a => a
mempty
        Just [NamelessField Position
x] -> CabalSpecVersion
-> NamelessField Position -> ParseResult src ShortText
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 src ()
forall src.
FieldName -> [NamelessField Position] -> ParseResult src ()
warnMultipleSingularFields FieldName
fn [NamelessField Position]
xs
          NonEmpty ShortText -> ShortText
forall a. NonEmpty a -> a
NE.last (NonEmpty ShortText -> ShortText)
-> ParseResult src (NonEmpty ShortText)
-> ParseResult src ShortText
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (NamelessField Position -> ParseResult src ShortText)
-> NonEmpty (NamelessField Position)
-> ParseResult src (NonEmpty ShortText)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> NonEmpty a -> f (NonEmpty b)
traverse (CabalSpecVersion
-> NamelessField Position -> ParseResult src ShortText
forall {f :: * -> *}.
Applicative f =>
CabalSpecVersion -> NamelessField Position -> f ShortText
parseOne CabalSpecVersion
v) (NamelessField Position
y NamelessField Position
-> [NamelessField Position] -> NonEmpty (NamelessField Position)
forall 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
        [] -> ShortText -> f ShortText
forall a. a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ShortText
forall a. Monoid a => a
mempty
        [FieldLine Position
_ FieldName
bs] -> ShortText -> f ShortText
forall a. a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (FieldName -> ShortText
ShortText.unsafeFromUTF8BS FieldName
bs)
        [FieldLine Position]
_
          | CabalSpecVersion
v CabalSpecVersion -> CabalSpecVersion -> Bool
forall a. Ord a => a -> a -> Bool
>= CabalSpecVersion
freeTextIgnoreDotlineVers -> ShortText -> f ShortText
forall a. a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (String -> ShortText
ShortText.toShortText (String -> ShortText) -> String -> ShortText
forall a b. (a -> b) -> a -> b
$ Position -> [FieldLine Position] -> String
fieldlinesToFreeText3 Position
pos [FieldLine Position]
fls)
          | Bool
otherwise -> ShortText -> f ShortText
forall a. a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (String -> ShortText
ShortText.toShortText (String -> ShortText) -> String -> ShortText
forall a b. (a -> b) -> a -> b
$ [FieldLine Position] -> String
forall ann. [FieldLine ann] -> String
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 = Set FieldName
-> Set FieldName
-> (forall src.
    CabalSpecVersion -> Fields Position -> ParseResult src a)
-> ParsecFieldGrammar s a
forall s a.
Set FieldName
-> Set FieldName
-> (forall src.
    CabalSpecVersion -> Fields Position -> ParseResult src a)
-> ParsecFieldGrammar s a
ParsecFG (FieldName -> Set FieldName
forall a. a -> Set a
Set.singleton FieldName
fn) Set FieldName
forall a. Set a
Set.empty CabalSpecVersion -> Fields Position -> ParseResult src a
forall src.
CabalSpecVersion -> Fields Position -> ParseResult src a
forall {t :: * -> *} {src}.
Traversable t =>
CabalSpecVersion
-> Map FieldName (t (NamelessField Position)) -> ParseResult src a
parser
    where
      parser :: CabalSpecVersion
-> Map FieldName (t (NamelessField Position)) -> ParseResult src a
parser CabalSpecVersion
v Map FieldName (t (NamelessField Position))
fields = case FieldName
-> Map FieldName (t (NamelessField Position))
-> Maybe (t (NamelessField Position))
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 -> a -> ParseResult src a
forall a. a -> ParseResult src a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
forall a. Monoid a => a
mempty
        Just t (NamelessField Position)
xs -> (b -> a) -> t b -> a
forall m a. Monoid m => (a -> m) -> t a -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap ((a -> b) -> b -> a
forall o n. Newtype o n => (o -> n) -> n -> o
unpack' a -> b
_pack) (t b -> a) -> ParseResult src (t b) -> ParseResult src a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (NamelessField Position -> ParseResult src b)
-> t (NamelessField Position) -> ParseResult src (t b)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> t a -> f (t b)
traverse (CabalSpecVersion -> NamelessField Position -> ParseResult src b
forall {a} {src}.
Parsec a =>
CabalSpecVersion -> NamelessField Position -> ParseResult src a
parseOne CabalSpecVersion
v) t (NamelessField Position)
xs

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

  prefixedFields :: forall s.
FieldName
-> ALens' s [(String, String)]
-> ParsecFieldGrammar s [(String, String)]
prefixedFields FieldName
fnPfx ALens' s [(String, String)]
_extract = Set FieldName
-> Set FieldName
-> (forall src.
    CabalSpecVersion
    -> Fields Position -> ParseResult src [(String, String)])
-> ParsecFieldGrammar s [(String, String)]
forall s a.
Set FieldName
-> Set FieldName
-> (forall src.
    CabalSpecVersion -> Fields Position -> ParseResult src a)
-> ParsecFieldGrammar s a
ParsecFG Set FieldName
forall a. Monoid a => a
mempty (FieldName -> Set FieldName
forall a. a -> Set a
Set.singleton FieldName
fnPfx) (\CabalSpecVersion
_ Fields Position
fs -> [(String, String)] -> ParseResult src [(String, String)]
forall a. a -> ParseResult src a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Fields Position -> [(String, String)]
parser Fields Position
fs))
    where
      parser :: Fields Position -> [(String, String)]
      parser :: Fields Position -> [(String, String)]
parser Fields Position
values = [(Position, (String, String))] -> [(String, String)]
forall {b}. [(Position, b)] -> [b]
reorder ([(Position, (String, String))] -> [(String, String)])
-> [(Position, (String, String))] -> [(String, String)]
forall a b. (a -> b) -> a -> b
$ ((FieldName, [NamelessField Position])
 -> [(Position, (String, String))])
-> [(FieldName, [NamelessField Position])]
-> [(Position, (String, String))]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (FieldName, [NamelessField Position])
-> [(Position, (String, String))]
forall {ann}.
(FieldName, [NamelessField ann]) -> [(ann, (String, String))]
convert ([(FieldName, [NamelessField Position])]
 -> [(Position, (String, String))])
-> [(FieldName, [NamelessField Position])]
-> [(Position, (String, String))]
forall a b. (a -> b) -> a -> b
$ ((FieldName, [NamelessField Position]) -> Bool)
-> [(FieldName, [NamelessField Position])]
-> [(FieldName, [NamelessField Position])]
forall a. (a -> Bool) -> [a] -> [a]
filter (FieldName, [NamelessField Position]) -> Bool
forall {b}. (FieldName, b) -> Bool
match ([(FieldName, [NamelessField Position])]
 -> [(FieldName, [NamelessField Position])])
-> [(FieldName, [NamelessField Position])]
-> [(FieldName, [NamelessField Position])]
forall a b. (a -> b) -> a -> b
$ Fields Position -> [(FieldName, [NamelessField Position])]
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, (String, String))]
convert (FieldName
fn, [NamelessField ann]
fields) =
        [ (ann
pos, (FieldName -> String
fromUTF8BS FieldName
fn, ShowS
trim ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ FieldName -> String
fromUTF8BS (FieldName -> String) -> FieldName -> String
forall a b. (a -> b) -> a -> b
$ [FieldLine ann] -> FieldName
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 = ((Position, b) -> b) -> [(Position, b)] -> [b]
forall a b. (a -> b) -> [a] -> [b]
map (Position, b) -> b
forall a b. (a, b) -> b
snd ([(Position, b)] -> [b])
-> ([(Position, b)] -> [(Position, b)]) -> [(Position, b)] -> [b]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Position, b) -> (Position, b) -> Ordering)
-> [(Position, b)] -> [(Position, b)]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy (((Position, b) -> Position)
-> (Position, b) -> (Position, b) -> Ordering
forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing (Position, b) -> Position
forall a b. (a, b) -> a
fst)

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

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

            CabalSpecVersion -> Fields Position -> ParseResult src a
forall src.
CabalSpecVersion -> Fields Position -> ParseResult src a
parser CabalSpecVersion
v Fields Position
values

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

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

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

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

            case [(FieldName, Position)]
namePos of
              -- no fields => proceed (with empty values, to be sure)
              [] -> CabalSpecVersion -> Fields Position -> ParseResult src a
forall src.
CabalSpecVersion -> Fields Position -> ParseResult src a
parser CabalSpecVersion
v Fields Position
forall a. Monoid a => a
mempty
              -- if there's single field: fail fatally with it
              ((FieldName
name, Position
pos) : [(FieldName, Position)]
rest) -> do
                [(FieldName, Position)]
-> ((FieldName, Position) -> ParseResult src ())
-> ParseResult src ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ [(FieldName, Position)]
rest (((FieldName, Position) -> ParseResult src ())
 -> ParseResult src ())
-> ((FieldName, Position) -> ParseResult src ())
-> ParseResult src ()
forall a b. (a -> b) -> a -> b
$ \(FieldName
name', Position
pos') -> Position -> String -> ParseResult src ()
forall src. Position -> String -> ParseResult src ()
parseFailure Position
pos' (String -> ParseResult src ()) -> String -> ParseResult src ()
forall a b. (a -> b) -> a -> b
$ FieldName -> String
forall a. Show a => a -> String
makeMsg FieldName
name'
                Position -> String -> ParseResult src a
forall src a. Position -> String -> ParseResult src a
parseFatalFailure Position
pos (String -> ParseResult src a) -> String -> ParseResult src a
forall a b. (a -> b) -> a -> b
$ FieldName -> String
forall a. Show a => a -> String
makeMsg FieldName
name
        | Bool
otherwise = CabalSpecVersion -> Fields Position -> ParseResult src a
forall src.
CabalSpecVersion -> Fields Position -> ParseResult src a
parser CabalSpecVersion
v Fields Position
values

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

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

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

runFieldParser' :: [Position] -> ParsecParser a -> CabalSpecVersion -> FieldLineStream -> ParseResult src a
runFieldParser' :: forall a src.
[Position]
-> ParsecParser a
-> CabalSpecVersion
-> FieldLineStream
-> ParseResult src a
runFieldParser' [Position]
inputPoss ParsecParser a
p CabalSpecVersion
v FieldLineStream
str = case Parsec FieldLineStream [PWarning] (a, [PWarning])
-> [PWarning]
-> String
-> FieldLineStream
-> Either ParseError (a, [PWarning])
forall s t u a.
Stream s Identity t =>
Parsec s u a -> u -> String -> s -> Either ParseError a
P.runParser Parsec FieldLineStream [PWarning] (a, [PWarning])
p' [] String
"<field>" FieldLineStream
str of
  Right (a
pok, [PWarning]
ws) -> do
    (PWarning -> ParseResult src ())
-> [PWarning] -> ParseResult src ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ (\(PWarning PWarnType
t Position
pos String
w) -> Position -> PWarnType -> String -> ParseResult src ()
forall src. Position -> PWarnType -> String -> ParseResult src ()
parseWarning (Position -> Position
mapPosition Position
pos) PWarnType
t String
w) [PWarning]
ws
    a -> ParseResult src a
forall a. a -> ParseResult src a
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 (Position -> Position) -> Position -> Position
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 :: String
msg =
          String
-> String -> String -> String -> String -> [Message] -> String
P.showErrorMessages
            String
"or"
            String
"unknown parse error"
            String
"expecting"
            String
"unexpected"
            String
"end of input"
            (ParseError -> [Message]
P.errorMessages ParseError
err)
    Position -> String -> ParseResult src a
forall src a. Position -> String -> ParseResult src a
parseFatalFailure Position
epos (String -> ParseResult src a) -> String -> ParseResult src a
forall a b. (a -> b) -> a -> b
$ String
msg String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"\n"
  where
    p' :: Parsec FieldLineStream [PWarning] (a, [PWarning])
p' = (,) (a -> [PWarning] -> (a, [PWarning]))
-> ParsecT FieldLineStream [PWarning] Identity ()
-> ParsecT
     FieldLineStream
     [PWarning]
     Identity
     (a -> [PWarning] -> (a, [PWarning]))
forall a b.
a
-> ParsecT FieldLineStream [PWarning] Identity b
-> ParsecT FieldLineStream [PWarning] Identity a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ ParsecT FieldLineStream [PWarning] Identity ()
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m ()
P.spaces ParsecT
  FieldLineStream
  [PWarning]
  Identity
  (a -> [PWarning] -> (a, [PWarning]))
-> ParsecT FieldLineStream [PWarning] Identity a
-> ParsecT
     FieldLineStream [PWarning] Identity ([PWarning] -> (a, [PWarning]))
forall a b.
ParsecT FieldLineStream [PWarning] Identity (a -> b)
-> ParsecT FieldLineStream [PWarning] Identity a
-> ParsecT FieldLineStream [PWarning] Identity b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ParsecParser a
-> CabalSpecVersion
-> ParsecT FieldLineStream [PWarning] Identity a
forall a.
ParsecParser a
-> CabalSpecVersion -> Parsec FieldLineStream [PWarning] a
unPP ParsecParser a
p CabalSpecVersion
v ParsecT
  FieldLineStream [PWarning] Identity ([PWarning] -> (a, [PWarning]))
-> ParsecT FieldLineStream [PWarning] Identity ()
-> ParsecT
     FieldLineStream [PWarning] Identity ([PWarning] -> (a, [PWarning]))
forall a b.
ParsecT FieldLineStream [PWarning] Identity a
-> ParsecT FieldLineStream [PWarning] Identity b
-> ParsecT FieldLineStream [PWarning] Identity a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* ParsecT FieldLineStream [PWarning] Identity ()
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m ()
P.spaces ParsecT
  FieldLineStream [PWarning] Identity ([PWarning] -> (a, [PWarning]))
-> ParsecT FieldLineStream [PWarning] Identity ()
-> ParsecT
     FieldLineStream [PWarning] Identity ([PWarning] -> (a, [PWarning]))
forall a b.
ParsecT FieldLineStream [PWarning] Identity a
-> ParsecT FieldLineStream [PWarning] Identity b
-> ParsecT FieldLineStream [PWarning] Identity a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* ParsecT FieldLineStream [PWarning] Identity ()
forall s (m :: * -> *) t u.
(Stream s m t, Show t) =>
ParsecT s u m ()
P.eof ParsecT
  FieldLineStream [PWarning] Identity ([PWarning] -> (a, [PWarning]))
-> ParsecT FieldLineStream [PWarning] Identity [PWarning]
-> Parsec FieldLineStream [PWarning] (a, [PWarning])
forall a b.
ParsecT FieldLineStream [PWarning] Identity (a -> b)
-> ParsecT FieldLineStream [PWarning] Identity a
-> ParsecT FieldLineStream [PWarning] Identity b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ParsecT FieldLineStream [PWarning] Identity [PWarning]
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) = Int -> [Position] -> Position
forall {t}. (Ord t, Num t) => t -> [Position] -> Position
go (Int
prow Int -> Int -> Int
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 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
pcol Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)
        go t
n (Position Int
row Int
col : [Position]
_) | t
n t -> t -> Bool
forall a. Ord a => a -> a -> Bool
<= t
0 = Int -> Int -> Position
Position Int
row (Int
col Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
pcol Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)
        go t
n (Position
_ : [Position]
ps) = t -> [Position] -> Position
go (t
n t -> t -> t
forall a. Num a => a -> a -> a
- t
1) [Position]
ps

runFieldParser :: Position -> ParsecParser a -> CabalSpecVersion -> [FieldLine Position] -> ParseResult src a
runFieldParser :: forall a src.
Position
-> ParsecParser a
-> CabalSpecVersion
-> [FieldLine Position]
-> ParseResult src a
runFieldParser Position
pp ParsecParser a
p CabalSpecVersion
v [FieldLine Position]
ls = [Position]
-> ParsecParser a
-> CabalSpecVersion
-> FieldLineStream
-> ParseResult src a
forall a src.
[Position]
-> ParsecParser a
-> CabalSpecVersion
-> FieldLineStream
-> ParseResult src a
runFieldParser' [Position]
poss ParsecParser a
p CabalSpecVersion
v ([FieldLine Position] -> FieldLineStream
forall ann. [FieldLine ann] -> FieldLineStream
fieldLinesToStream [FieldLine Position]
ls)
  where
    poss :: [Position]
poss = (FieldLine Position -> Position)
-> [FieldLine Position] -> [Position]
forall a b. (a -> b) -> [a] -> [b]
map (\(FieldLine Position
pos FieldName
_) -> Position
pos) [FieldLine Position]
ls [Position] -> [Position] -> [Position]
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" ([FieldName] -> FieldName)
-> ([FieldLine ann] -> [FieldName]) -> [FieldLine ann] -> FieldName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (FieldLine ann -> FieldName) -> [FieldLine ann] -> [FieldName]
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] -> String
fieldlinesToFreeText [FieldLine ann
_ FieldName
"."] = String
"."
fieldlinesToFreeText [FieldLine ann]
fls = String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
"\n" ((FieldLine ann -> String) -> [FieldLine ann] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map FieldLine ann -> String
forall {ann}. FieldLine ann -> String
go [FieldLine ann]
fls)
  where
    go :: FieldLine ann -> String
go (FieldLine ann
_ FieldName
bs)
      | String
s String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"." = String
""
      | Bool
otherwise = String
s
      where
        s :: String
s = ShowS
trim (FieldName -> String
fromUTF8BS FieldName
bs)

-- | Cabal version where we switch from the old free text parser that had
-- special logic for "dotlines" to a new parser that has no such logic.
freeTextIgnoreDotlineVers :: CabalSpecVersion
freeTextIgnoreDotlineVers :: CabalSpecVersion
freeTextIgnoreDotlineVers = CabalSpecVersion
CabalSpecV3_0

fieldlinesToFreeText3 :: Position -> [FieldLine Position] -> String
fieldlinesToFreeText3 :: Position -> [FieldLine Position] -> String
fieldlinesToFreeText3 Position
_ [] = String
""
fieldlinesToFreeText3 Position
_ [FieldLine Position
_ FieldName
bs] = FieldName -> String
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 Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Position -> Int
positionRow Position
pos1 =
      [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$
        FieldName -> String
fromUTF8BS FieldName
bs1
          String -> [String] -> [String]
forall a. a -> [a] -> [a]
: (Position -> FieldLine Position -> (Position, String))
-> Position -> [FieldLine Position] -> [String]
forall s a b. (s -> a -> (s, b)) -> s -> [a] -> [b]
mealy (Int -> Position -> FieldLine Position -> (Position, String)
mk Int
mcol1) Position
pos1 [FieldLine Position]
fls2
  -- otherwise, also indent the first line
  | Bool
otherwise =
      [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$
        Int -> Char -> String
forall a. Int -> a -> [a]
replicate (Position -> Int
positionCol Position
pos1 Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
mcol2) Char
' '
          String -> [String] -> [String]
forall a. a -> [a] -> [a]
: FieldName -> String
fromUTF8BS FieldName
bs1
          String -> [String] -> [String]
forall a. a -> [a] -> [a]
: (Position -> FieldLine Position -> (Position, String))
-> Position -> [FieldLine Position] -> [String]
forall s a b. (s -> a -> (s, b)) -> s -> [a] -> [b]
mealy (Int -> Position -> FieldLine Position -> (Position, String)
mk Int
mcol2) Position
pos1 [FieldLine Position]
fls2
  where
    mcol1 :: Int
mcol1 = (Int -> FieldLine Position -> Int)
-> Int -> [FieldLine Position] -> Int
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (\Int
a FieldLine Position
b -> Int -> Int -> Int
forall a. Ord a => a -> a -> a
min Int
a (Int -> Int) -> Int -> Int
forall a b. (a -> b) -> a -> b
$ Position -> Int
positionCol (Position -> Int) -> Position -> Int
forall a b. (a -> b) -> a -> b
$ FieldLine Position -> Position
forall ann. FieldLine ann -> ann
fieldLineAnn FieldLine Position
b) (Int -> Int -> Int
forall a. Ord a => a -> a -> a
min (Position -> Int
positionCol Position
pos1) (Position -> Int
positionCol Position
pos2)) [FieldLine Position]
fls2
    mcol2 :: Int
mcol2 = (Int -> FieldLine Position -> Int)
-> Int -> [FieldLine Position] -> Int
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (\Int
a FieldLine Position
b -> Int -> Int -> Int
forall a. Ord a => a -> a -> a
min Int
a (Int -> Int) -> Int -> Int
forall a b. (a -> b) -> a -> b
$ Position -> Int
positionCol (Position -> Int) -> Position -> Int
forall a b. (a -> b) -> a -> b
$ FieldLine Position -> Position
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, String)
mk Int
col Position
p (FieldLine Position
q FieldName
bs) =
      ( Position
q
      , Int -> Char -> String
forall a. Int -> a -> [a]
replicate Int
newlines Char
'\n'
          String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> Char -> String
forall a. Int -> a -> [a]
replicate Int
indent Char
' '
          String -> ShowS
forall a. [a] -> [a] -> [a]
++ FieldName -> String
fromUTF8BS FieldName
bs
      )
      where
        newlines :: Int
newlines = Position -> Int
positionRow Position
q Int -> Int -> Int
forall a. Num a => a -> a -> a
- Position -> Int
positionRow Position
p
        indent :: Int
indent = Position -> Int
positionCol Position
q Int -> Int -> Int
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 b -> [b] -> [b]
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 ([FieldLine ann] -> FieldLineStream
forall ann. [FieldLine ann] -> FieldLineStream
fieldLinesToStream [FieldLine ann]
fs)