{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Distribution.FieldGrammar.Parsec (
ParsecFieldGrammar,
parseFieldGrammar,
fieldGrammarKnownFieldList,
Fields,
NamelessField (..),
namelessFieldAnn,
Section (..),
runFieldParser,
runFieldParser',
fieldLinesToStream,
) where
import Data.List (dropWhileEnd)
import Data.Ord (comparing)
import Data.Set (Set)
import Distribution.Compat.Newtype
import Distribution.Compat.Prelude
import Distribution.Simple.Utils (fromUTF8BS)
import Prelude ()
import qualified Data.ByteString as BS
import qualified Data.Map.Strict as Map
import qualified Data.Set as Set
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 (positionRow, positionCol)
type Fields ann = Map FieldName [NamelessField ann]
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
/= :: 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
[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
showList :: [NamelessField ann] -> ShowS
$cshowList :: forall ann. Show ann => [NamelessField ann] -> ShowS
show :: NamelessField ann -> String
$cshow :: forall ann. Show ann => NamelessField ann -> String
showsPrec :: Int -> NamelessField ann -> ShowS
$cshowsPrec :: forall ann. Show ann => Int -> NamelessField ann -> ShowS
Show, a -> NamelessField b -> NamelessField a
(a -> b) -> NamelessField a -> NamelessField b
(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
<$ :: a -> NamelessField b -> NamelessField a
$c<$ :: forall a b. a -> NamelessField b -> NamelessField a
fmap :: (a -> b) -> NamelessField a -> NamelessField b
$cfmap :: forall a b. (a -> b) -> NamelessField a -> NamelessField b
Functor)
namelessFieldAnn :: NamelessField ann -> ann
namelessFieldAnn :: NamelessField ann -> ann
namelessFieldAnn (MkNamelessField ann :: ann
ann _) = ann
ann
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
/= :: 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
[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
showList :: [Section ann] -> ShowS
$cshowList :: forall ann. Show ann => [Section ann] -> ShowS
show :: Section ann -> String
$cshow :: forall ann. Show ann => Section ann -> String
showsPrec :: Int -> Section ann -> ShowS
$cshowsPrec :: forall ann. Show ann => Int -> Section ann -> ShowS
Show, a -> Section b -> Section a
(a -> b) -> Section a -> Section b
(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
<$ :: a -> Section b -> Section a
$c<$ :: forall a b. a -> Section b -> Section a
fmap :: (a -> b) -> Section a -> Section b
$cfmap :: forall a b. (a -> b) -> Section a -> Section b
Functor)
data ParsecFieldGrammar s a = ParsecFG
{ ParsecFieldGrammar s a -> Set FieldName
fieldGrammarKnownFields :: !(Set FieldName)
, ParsecFieldGrammar s a -> Set FieldName
fieldGrammarKnownPrefixes :: !(Set FieldName)
, ParsecFieldGrammar s a
-> CabalSpecVersion -> Fields Position -> ParseResult a
fieldGrammarParser :: !(CabalSpecVersion -> Fields Position -> ParseResult a)
}
deriving (a -> ParsecFieldGrammar s b -> ParsecFieldGrammar s a
(a -> b) -> ParsecFieldGrammar s a -> ParsecFieldGrammar s b
(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
<$ :: a -> ParsecFieldGrammar s b -> ParsecFieldGrammar s a
$c<$ :: forall s a b. a -> ParsecFieldGrammar s b -> ParsecFieldGrammar s a
fmap :: (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 :: CabalSpecVersion
-> Fields Position -> ParsecFieldGrammar s a -> ParseResult a
parseFieldGrammar v :: CabalSpecVersion
v fields :: Fields Position
fields grammar :: ParsecFieldGrammar s a
grammar = do
[(FieldName, [NamelessField Position])]
-> ((FieldName, [NamelessField Position]) -> ParseResult ())
-> ParseResult ()
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 FieldName -> [NamelessField Position] -> Bool
forall p. FieldName -> p -> Bool
isUnknownField Fields Position
fields)) (((FieldName, [NamelessField Position]) -> ParseResult ())
-> ParseResult ())
-> ((FieldName, [NamelessField Position]) -> ParseResult ())
-> ParseResult ()
forall a b. (a -> b) -> a -> b
$ \(name :: FieldName
name, nfields :: [NamelessField Position]
nfields) ->
[NamelessField Position]
-> (NamelessField Position -> ParseResult ()) -> ParseResult ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ [NamelessField Position]
nfields ((NamelessField Position -> ParseResult ()) -> ParseResult ())
-> (NamelessField Position -> ParseResult ()) -> ParseResult ()
forall a b. (a -> b) -> a -> b
$ \(MkNamelessField pos :: Position
pos _) ->
Position -> PWarnType -> String -> ParseResult ()
parseWarning Position
pos PWarnType
PWTUnknownField (String -> ParseResult ()) -> String -> ParseResult ()
forall a b. (a -> b) -> a -> b
$ "Unknown field: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ FieldName -> String
forall a. Show a => a -> String
show FieldName
name
ParsecFieldGrammar s a
-> CabalSpecVersion -> Fields Position -> ParseResult a
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 k :: FieldName
k _ = 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)
fieldGrammarKnownFieldList :: ParsecFieldGrammar s a -> [FieldName]
fieldGrammarKnownFieldList :: 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 :: a -> ParsecFieldGrammar s a
pure x :: a
x = Set FieldName
-> Set FieldName
-> (CabalSpecVersion -> Fields Position -> ParseResult a)
-> ParsecFieldGrammar s a
forall s a.
Set FieldName
-> Set FieldName
-> (CabalSpecVersion -> Fields Position -> ParseResult a)
-> ParsecFieldGrammar s a
ParsecFG Set FieldName
forall a. Monoid a => a
mempty Set FieldName
forall a. Monoid a => a
mempty (\_ _ -> a -> ParseResult a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
x)
{-# INLINE pure #-}
ParsecFG f :: Set FieldName
f f' :: Set FieldName
f' f'' :: CabalSpecVersion -> Fields Position -> ParseResult (a -> b)
f'' <*> :: ParsecFieldGrammar s (a -> b)
-> ParsecFieldGrammar s a -> ParsecFieldGrammar s b
<*> ParsecFG x :: Set FieldName
x x' :: Set FieldName
x' x'' :: CabalSpecVersion -> Fields Position -> ParseResult a
x'' = Set FieldName
-> Set FieldName
-> (CabalSpecVersion -> Fields Position -> ParseResult b)
-> ParsecFieldGrammar s b
forall s a.
Set FieldName
-> Set FieldName
-> (CabalSpecVersion -> Fields Position -> ParseResult 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')
(\v :: CabalSpecVersion
v fields :: Fields Position
fields -> CabalSpecVersion -> Fields Position -> ParseResult (a -> b)
f'' CabalSpecVersion
v Fields Position
fields ParseResult (a -> b) -> ParseResult a -> ParseResult b
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 _ [] = () -> ParseResult ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
warnMultipleSingularFields fn :: FieldName
fn (x :: NamelessField Position
x : xs :: [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 ()
parseWarning Position
pos PWarnType
PWTMultipleSingularField (String -> ParseResult ()) -> String -> ParseResult ()
forall a b. (a -> b) -> a -> b
$
"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
<> " is specified more than once at positions " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate ", " ((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 ParsecFieldGrammar where
blurFieldGrammar :: ALens' a b -> ParsecFieldGrammar b c -> ParsecFieldGrammar a c
blurFieldGrammar _ (ParsecFG s :: Set FieldName
s s' :: Set FieldName
s' parser :: CabalSpecVersion -> Fields Position -> ParseResult c
parser) = Set FieldName
-> Set FieldName
-> (CabalSpecVersion -> Fields Position -> ParseResult c)
-> ParsecFieldGrammar a c
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 c
parser
uniqueFieldAla :: FieldName -> (a -> b) -> ALens' s a -> ParsecFieldGrammar s a
uniqueFieldAla fn :: FieldName
fn _pack :: a -> b
_pack _extract :: ALens' s a
_extract = Set FieldName
-> Set FieldName
-> (CabalSpecVersion -> Fields Position -> ParseResult a)
-> ParsecFieldGrammar s a
forall s a.
Set FieldName
-> Set FieldName
-> (CabalSpecVersion -> Fields Position -> ParseResult 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 a
parser
where
parser :: CabalSpecVersion -> Fields Position -> ParseResult a
parser v :: CabalSpecVersion
v fields :: 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
Nothing -> Position -> String -> ParseResult a
forall a. Position -> String -> ParseResult a
parseFatalFailure Position
zeroPos (String -> ParseResult a) -> String -> ParseResult 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]
++ " field missing"
Just [] -> Position -> String -> ParseResult a
forall a. Position -> String -> ParseResult a
parseFatalFailure Position
zeroPos (String -> ParseResult a) -> String -> ParseResult 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]
++ " field missing"
Just [x :: NamelessField Position
x] -> CabalSpecVersion -> NamelessField Position -> ParseResult a
parseOne CabalSpecVersion
v NamelessField Position
x
Just xs :: [NamelessField Position]
xs -> do
FieldName -> [NamelessField Position] -> ParseResult ()
warnMultipleSingularFields FieldName
fn [NamelessField Position]
xs
[a] -> a
forall a. [a] -> a
last ([a] -> a) -> ParseResult [a] -> ParseResult a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (NamelessField Position -> ParseResult a)
-> [NamelessField Position] -> ParseResult [a]
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]
xs
parseOne :: CabalSpecVersion -> NamelessField Position -> ParseResult a
parseOne v :: CabalSpecVersion
v (MkNamelessField pos :: Position
pos fls :: [FieldLine Position]
fls) =
(a -> b) -> b -> a
forall o n. Newtype o n => (o -> n) -> n -> o
unpack' a -> b
_pack (b -> a) -> ParseResult b -> ParseResult a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Position
-> ParsecParser b
-> CabalSpecVersion
-> [FieldLine Position]
-> ParseResult b
forall a.
Position
-> ParsecParser a
-> CabalSpecVersion
-> [FieldLine Position]
-> ParseResult a
runFieldParser Position
pos ParsecParser b
forall a (m :: * -> *). (Parsec a, CabalParsing m) => m a
parsec CabalSpecVersion
v [FieldLine Position]
fls
booleanFieldDef :: FieldName -> ALens' s Bool -> Bool -> ParsecFieldGrammar s Bool
booleanFieldDef fn :: FieldName
fn _extract :: ALens' s Bool
_extract def :: Bool
def = Set FieldName
-> Set FieldName
-> (CabalSpecVersion -> Fields Position -> ParseResult Bool)
-> ParsecFieldGrammar s Bool
forall s a.
Set FieldName
-> Set FieldName
-> (CabalSpecVersion -> Fields Position -> ParseResult 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 Bool
parser
where
parser :: CabalSpecVersion -> Fields Position -> ParseResult Bool
parser v :: CabalSpecVersion
v fields :: 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
Nothing -> Bool -> ParseResult Bool
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
def
Just [] -> Bool -> ParseResult Bool
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
def
Just [x :: NamelessField Position
x] -> CabalSpecVersion -> NamelessField Position -> ParseResult Bool
forall a.
Parsec a =>
CabalSpecVersion -> NamelessField Position -> ParseResult a
parseOne CabalSpecVersion
v NamelessField Position
x
Just xs :: [NamelessField Position]
xs -> do
FieldName -> [NamelessField Position] -> ParseResult ()
warnMultipleSingularFields FieldName
fn [NamelessField Position]
xs
[Bool] -> Bool
forall a. [a] -> a
last ([Bool] -> Bool) -> ParseResult [Bool] -> ParseResult Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (NamelessField Position -> ParseResult Bool)
-> [NamelessField Position] -> ParseResult [Bool]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (CabalSpecVersion -> NamelessField Position -> ParseResult Bool
forall a.
Parsec a =>
CabalSpecVersion -> NamelessField Position -> ParseResult a
parseOne CabalSpecVersion
v) [NamelessField Position]
xs
parseOne :: CabalSpecVersion -> NamelessField Position -> ParseResult a
parseOne v :: CabalSpecVersion
v (MkNamelessField pos :: Position
pos fls :: [FieldLine Position]
fls) = Position
-> ParsecParser a
-> CabalSpecVersion
-> [FieldLine Position]
-> ParseResult a
forall a.
Position
-> ParsecParser a
-> CabalSpecVersion
-> [FieldLine Position]
-> ParseResult a
runFieldParser Position
pos ParsecParser a
forall a (m :: * -> *). (Parsec a, CabalParsing m) => m a
parsec CabalSpecVersion
v [FieldLine Position]
fls
optionalFieldAla :: FieldName
-> (a -> b) -> ALens' s (Maybe a) -> ParsecFieldGrammar s (Maybe a)
optionalFieldAla fn :: FieldName
fn _pack :: a -> b
_pack _extract :: ALens' s (Maybe a)
_extract = Set FieldName
-> Set FieldName
-> (CabalSpecVersion -> Fields Position -> ParseResult (Maybe a))
-> ParsecFieldGrammar s (Maybe a)
forall s a.
Set FieldName
-> Set FieldName
-> (CabalSpecVersion -> Fields Position -> ParseResult 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 (Maybe a)
parser
where
parser :: CabalSpecVersion -> Fields Position -> ParseResult (Maybe a)
parser v :: CabalSpecVersion
v fields :: 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
Nothing -> Maybe a -> ParseResult (Maybe a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe a
forall a. Maybe a
Nothing
Just [] -> Maybe a -> ParseResult (Maybe a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe a
forall a. Maybe a
Nothing
Just [x :: NamelessField Position
x] -> CabalSpecVersion -> NamelessField Position -> ParseResult (Maybe a)
parseOne CabalSpecVersion
v NamelessField Position
x
Just xs :: [NamelessField Position]
xs -> do
FieldName -> [NamelessField Position] -> ParseResult ()
warnMultipleSingularFields FieldName
fn [NamelessField Position]
xs
[Maybe a] -> Maybe a
forall a. [a] -> a
last ([Maybe a] -> Maybe a)
-> ParseResult [Maybe a] -> ParseResult (Maybe a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (NamelessField Position -> ParseResult (Maybe a))
-> [NamelessField Position] -> ParseResult [Maybe a]
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]
xs
parseOne :: CabalSpecVersion -> NamelessField Position -> ParseResult (Maybe a)
parseOne v :: CabalSpecVersion
v (MkNamelessField pos :: Position
pos fls :: [FieldLine Position]
fls)
| [FieldLine Position] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [FieldLine Position]
fls = Maybe a -> ParseResult (Maybe 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 b -> ParseResult (Maybe a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Position
-> ParsecParser b
-> CabalSpecVersion
-> [FieldLine Position]
-> ParseResult b
forall a.
Position
-> ParsecParser a
-> CabalSpecVersion
-> [FieldLine Position]
-> ParseResult a
runFieldParser Position
pos ParsecParser b
forall a (m :: * -> *). (Parsec a, CabalParsing m) => m a
parsec CabalSpecVersion
v [FieldLine Position]
fls
optionalFieldDefAla :: FieldName -> (a -> b) -> ALens' s a -> a -> ParsecFieldGrammar s a
optionalFieldDefAla fn :: FieldName
fn _pack :: a -> b
_pack _extract :: ALens' s a
_extract def :: a
def = Set FieldName
-> Set FieldName
-> (CabalSpecVersion -> Fields Position -> ParseResult a)
-> ParsecFieldGrammar s a
forall s a.
Set FieldName
-> Set FieldName
-> (CabalSpecVersion -> Fields Position -> ParseResult 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 a
parser
where
parser :: CabalSpecVersion -> Fields Position -> ParseResult a
parser v :: CabalSpecVersion
v fields :: 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
Nothing -> a -> ParseResult a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
def
Just [] -> a -> ParseResult a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
def
Just [x :: NamelessField Position
x] -> CabalSpecVersion -> NamelessField Position -> ParseResult a
parseOne CabalSpecVersion
v NamelessField Position
x
Just xs :: [NamelessField Position]
xs -> do
FieldName -> [NamelessField Position] -> ParseResult ()
warnMultipleSingularFields FieldName
fn [NamelessField Position]
xs
[a] -> a
forall a. [a] -> a
last ([a] -> a) -> ParseResult [a] -> ParseResult a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (NamelessField Position -> ParseResult a)
-> [NamelessField Position] -> ParseResult [a]
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]
xs
parseOne :: CabalSpecVersion -> NamelessField Position -> ParseResult a
parseOne v :: CabalSpecVersion
v (MkNamelessField pos :: Position
pos fls :: [FieldLine Position]
fls)
| [FieldLine Position] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [FieldLine Position]
fls = a -> ParseResult 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 b -> ParseResult a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Position
-> ParsecParser b
-> CabalSpecVersion
-> [FieldLine Position]
-> ParseResult b
forall a.
Position
-> ParsecParser a
-> CabalSpecVersion
-> [FieldLine Position]
-> ParseResult a
runFieldParser Position
pos ParsecParser b
forall a (m :: * -> *). (Parsec a, CabalParsing m) => m a
parsec CabalSpecVersion
v [FieldLine Position]
fls
freeTextField :: FieldName
-> ALens' s (Maybe String) -> ParsecFieldGrammar s (Maybe String)
freeTextField fn :: FieldName
fn _ = Set FieldName
-> Set FieldName
-> (CabalSpecVersion
-> Fields Position -> ParseResult (Maybe String))
-> ParsecFieldGrammar s (Maybe String)
forall s a.
Set FieldName
-> Set FieldName
-> (CabalSpecVersion -> Fields Position -> ParseResult 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 (Maybe String)
parser where
parser :: CabalSpecVersion -> Fields Position -> ParseResult (Maybe String)
parser v :: CabalSpecVersion
v fields :: 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
Nothing -> Maybe String -> ParseResult (Maybe String)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe String
forall a. Maybe a
Nothing
Just [] -> Maybe String -> ParseResult (Maybe String)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe String
forall a. Maybe a
Nothing
Just [x :: NamelessField Position
x] -> CabalSpecVersion
-> NamelessField Position -> ParseResult (Maybe String)
forall (f :: * -> *).
Applicative f =>
CabalSpecVersion -> NamelessField Position -> f (Maybe String)
parseOne CabalSpecVersion
v NamelessField Position
x
Just xs :: [NamelessField Position]
xs -> do
FieldName -> [NamelessField Position] -> ParseResult ()
warnMultipleSingularFields FieldName
fn [NamelessField Position]
xs
[Maybe String] -> Maybe String
forall a. [a] -> a
last ([Maybe String] -> Maybe String)
-> ParseResult [Maybe String] -> ParseResult (Maybe String)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (NamelessField Position -> ParseResult (Maybe String))
-> [NamelessField Position] -> ParseResult [Maybe String]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (CabalSpecVersion
-> NamelessField Position -> ParseResult (Maybe String)
forall (f :: * -> *).
Applicative f =>
CabalSpecVersion -> NamelessField Position -> f (Maybe String)
parseOne CabalSpecVersion
v) [NamelessField Position]
xs
parseOne :: CabalSpecVersion -> NamelessField Position -> f (Maybe String)
parseOne v :: CabalSpecVersion
v (MkNamelessField pos :: Position
pos fls :: [FieldLine Position]
fls)
| [FieldLine Position] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [FieldLine Position]
fls = Maybe String -> f (Maybe String)
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
CabalSpecV3_0 = Maybe String -> f (Maybe String)
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 (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 :: FieldName -> ALens' s String -> ParsecFieldGrammar s String
freeTextFieldDef fn :: FieldName
fn _ = Set FieldName
-> Set FieldName
-> (CabalSpecVersion -> Fields Position -> ParseResult String)
-> ParsecFieldGrammar s String
forall s a.
Set FieldName
-> Set FieldName
-> (CabalSpecVersion -> Fields Position -> ParseResult 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 String
parser where
parser :: CabalSpecVersion -> Fields Position -> ParseResult String
parser v :: CabalSpecVersion
v fields :: 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
Nothing -> String -> ParseResult String
forall (f :: * -> *) a. Applicative f => a -> f a
pure ""
Just [] -> String -> ParseResult String
forall (f :: * -> *) a. Applicative f => a -> f a
pure ""
Just [x :: NamelessField Position
x] -> CabalSpecVersion -> NamelessField Position -> ParseResult String
forall (f :: * -> *).
Applicative f =>
CabalSpecVersion -> NamelessField Position -> f String
parseOne CabalSpecVersion
v NamelessField Position
x
Just xs :: [NamelessField Position]
xs -> do
FieldName -> [NamelessField Position] -> ParseResult ()
warnMultipleSingularFields FieldName
fn [NamelessField Position]
xs
[String] -> String
forall a. [a] -> a
last ([String] -> String) -> ParseResult [String] -> ParseResult String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (NamelessField Position -> ParseResult String)
-> [NamelessField Position] -> ParseResult [String]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (CabalSpecVersion -> NamelessField Position -> ParseResult String
forall (f :: * -> *).
Applicative f =>
CabalSpecVersion -> NamelessField Position -> f String
parseOne CabalSpecVersion
v) [NamelessField Position]
xs
parseOne :: CabalSpecVersion -> NamelessField Position -> f String
parseOne v :: CabalSpecVersion
v (MkNamelessField pos :: Position
pos fls :: [FieldLine Position]
fls)
| [FieldLine Position] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [FieldLine Position]
fls = String -> f String
forall (f :: * -> *) a. Applicative f => a -> f a
pure ""
| CabalSpecVersion
v CabalSpecVersion -> CabalSpecVersion -> Bool
forall a. Ord a => a -> a -> Bool
>= CabalSpecVersion
CabalSpecV3_0 = String -> f String
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 (f :: * -> *) a. Applicative f => a -> f a
pure ([FieldLine Position] -> String
forall ann. [FieldLine ann] -> String
fieldlinesToFreeText [FieldLine Position]
fls)
monoidalFieldAla :: FieldName -> (a -> b) -> ALens' s a -> ParsecFieldGrammar s a
monoidalFieldAla fn :: FieldName
fn _pack :: a -> b
_pack _extract :: ALens' s a
_extract = Set FieldName
-> Set FieldName
-> (CabalSpecVersion -> Fields Position -> ParseResult a)
-> ParsecFieldGrammar s a
forall s a.
Set FieldName
-> Set FieldName
-> (CabalSpecVersion -> Fields Position -> ParseResult 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 a
forall (t :: * -> *).
Traversable t =>
CabalSpecVersion
-> Map FieldName (t (NamelessField Position)) -> ParseResult a
parser
where
parser :: CabalSpecVersion
-> Map FieldName (t (NamelessField Position)) -> ParseResult a
parser v :: CabalSpecVersion
v fields :: 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
Nothing -> a -> ParseResult a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
forall a. Monoid a => a
mempty
Just xs :: t (NamelessField Position)
xs -> (b -> a) -> t b -> a
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 (t b) -> ParseResult a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (NamelessField Position -> ParseResult b)
-> t (NamelessField Position) -> ParseResult (t b)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (CabalSpecVersion -> NamelessField Position -> ParseResult b
forall a.
Parsec a =>
CabalSpecVersion -> NamelessField Position -> ParseResult a
parseOne CabalSpecVersion
v) t (NamelessField Position)
xs
parseOne :: CabalSpecVersion -> NamelessField Position -> ParseResult a
parseOne v :: CabalSpecVersion
v (MkNamelessField pos :: Position
pos fls :: [FieldLine Position]
fls) = Position
-> ParsecParser a
-> CabalSpecVersion
-> [FieldLine Position]
-> ParseResult a
forall a.
Position
-> ParsecParser a
-> CabalSpecVersion
-> [FieldLine Position]
-> ParseResult a
runFieldParser Position
pos ParsecParser a
forall a (m :: * -> *). (Parsec a, CabalParsing m) => m a
parsec CabalSpecVersion
v [FieldLine Position]
fls
prefixedFields :: FieldName
-> ALens' s [(String, String)]
-> ParsecFieldGrammar s [(String, String)]
prefixedFields fnPfx :: FieldName
fnPfx _extract :: ALens' s [(String, String)]
_extract = Set FieldName
-> Set FieldName
-> (CabalSpecVersion
-> Fields Position -> ParseResult [(String, String)])
-> ParsecFieldGrammar s [(String, String)]
forall s a.
Set FieldName
-> Set FieldName
-> (CabalSpecVersion -> Fields Position -> ParseResult 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) (\_ fs :: Fields Position
fs -> [(String, String)] -> ParseResult [(String, String)]
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 values :: 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 (fn :: FieldName
fn, _) = FieldName
fnPfx FieldName -> FieldName -> Bool
`BS.isPrefixOf` FieldName
fn
convert :: (FieldName, [NamelessField ann]) -> [(ann, (String, String))]
convert (fn :: FieldName
fn, fields :: [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 pos :: ann
pos fls :: [FieldLine ann]
fls <- [NamelessField ann]
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)
trim :: String -> String
trim :: ShowS
trim = (Char -> Bool) -> ShowS
forall a. (a -> Bool) -> [a] -> [a]
dropWhile Char -> Bool
isSpace ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> ShowS
forall a. (a -> Bool) -> [a] -> [a]
dropWhileEnd Char -> Bool
isSpace
availableSince :: CabalSpecVersion
-> a -> ParsecFieldGrammar s a -> ParsecFieldGrammar s a
availableSince vs :: CabalSpecVersion
vs def :: a
def (ParsecFG names :: Set FieldName
names prefixes :: Set FieldName
prefixes parser :: CabalSpecVersion -> Fields Position -> ParseResult a
parser) = Set FieldName
-> Set FieldName
-> (CabalSpecVersion -> Fields Position -> ParseResult a)
-> ParsecFieldGrammar s a
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' v :: CabalSpecVersion
v values :: Fields Position
values
| CabalSpecVersion
v CabalSpecVersion -> CabalSpecVersion -> Bool
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 = 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 ())
-> ParseResult ()
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 ())
-> ParseResult ())
-> ((FieldName, [NamelessField Position]) -> ParseResult ())
-> ParseResult ()
forall a b. (a -> b) -> a -> b
$ \(name :: FieldName
name, fields :: [NamelessField Position]
fields) ->
[NamelessField Position]
-> (NamelessField Position -> ParseResult ()) -> ParseResult ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ [NamelessField Position]
fields ((NamelessField Position -> ParseResult ()) -> ParseResult ())
-> (NamelessField Position -> ParseResult ()) -> ParseResult ()
forall a b. (a -> b) -> a -> b
$ \(MkNamelessField pos :: Position
pos _) ->
Position -> PWarnType -> String -> ParseResult ()
parseWarning Position
pos PWarnType
PWTUnknownField (String -> ParseResult ()) -> String -> ParseResult ()
forall a b. (a -> b) -> a -> b
$
"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
<> " 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]
++ ". This field will be ignored."
a -> ParseResult a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
def
deprecatedSince :: CabalSpecVersion
-> String -> ParsecFieldGrammar s a -> ParsecFieldGrammar s a
deprecatedSince vs :: CabalSpecVersion
vs msg :: String
msg (ParsecFG names :: Set FieldName
names prefixes :: Set FieldName
prefixes parser :: CabalSpecVersion -> Fields Position -> ParseResult a
parser) = Set FieldName
-> Set FieldName
-> (CabalSpecVersion -> Fields Position -> ParseResult a)
-> ParsecFieldGrammar s a
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' v :: CabalSpecVersion
v values :: 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 ())
-> ParseResult ()
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 ())
-> ParseResult ())
-> ((FieldName, [NamelessField Position]) -> ParseResult ())
-> ParseResult ()
forall a b. (a -> b) -> a -> b
$ \(name :: FieldName
name, fields :: [NamelessField Position]
fields) ->
[NamelessField Position]
-> (NamelessField Position -> ParseResult ()) -> ParseResult ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ [NamelessField Position]
fields ((NamelessField Position -> ParseResult ()) -> ParseResult ())
-> (NamelessField Position -> ParseResult ()) -> ParseResult ()
forall a b. (a -> b) -> a -> b
$ \(MkNamelessField pos :: Position
pos _) ->
Position -> PWarnType -> String -> ParseResult ()
parseWarning Position
pos PWarnType
PWTDeprecatedField (String -> ParseResult ()) -> String -> ParseResult ()
forall a b. (a -> b) -> a -> b
$
"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
<> " 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 -> ShowS
forall a. [a] -> [a] -> [a]
++ String
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 :: CabalSpecVersion
-> String -> ParsecFieldGrammar s a -> ParsecFieldGrammar s a
removedIn vs :: CabalSpecVersion
vs msg :: String
msg (ParsecFG names :: Set FieldName
names prefixes :: Set FieldName
prefixes parser :: CabalSpecVersion -> Fields Position -> ParseResult a
parser) = Set FieldName
-> Set FieldName
-> (CabalSpecVersion -> Fields Position -> ParseResult a)
-> ParsecFieldGrammar s a
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' v :: CabalSpecVersion
v values :: 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 (t :: * -> *) a. Foldable t => t a -> Bool
null String
msg then "" else ' ' 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)
| (name :: FieldName
name, fields :: [NamelessField Position]
fields) <- Fields Position -> [(FieldName, [NamelessField Position])]
forall k a. Map k a -> [(k, a)]
Map.toList Fields Position
unknownFields
, MkNamelessField pos :: Position
pos _ <- [NamelessField Position]
fields
]
let makeMsg :: a -> String
makeMsg name :: a
name = "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
<> " 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 -> ShowS
forall a. [a] -> [a] -> [a]
++ String
msg'
case [(FieldName, Position)]
namePos of
[] -> CabalSpecVersion -> Fields Position -> ParseResult a
parser CabalSpecVersion
v Fields Position
forall a. Monoid a => a
mempty
((name :: FieldName
name, pos :: Position
pos) : rest :: [(FieldName, Position)]
rest) -> do
[(FieldName, Position)]
-> ((FieldName, Position) -> ParseResult ()) -> ParseResult ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ [(FieldName, Position)]
rest (((FieldName, Position) -> ParseResult ()) -> ParseResult ())
-> ((FieldName, Position) -> ParseResult ()) -> ParseResult ()
forall a b. (a -> b) -> a -> b
$ \(name' :: FieldName
name', pos' :: Position
pos') -> Position -> String -> ParseResult ()
parseFailure Position
pos' (String -> ParseResult ()) -> String -> ParseResult ()
forall a b. (a -> b) -> a -> b
$ FieldName -> String
forall a. Show a => a -> String
makeMsg FieldName
name'
Position -> String -> ParseResult a
forall a. Position -> String -> ParseResult a
parseFatalFailure Position
pos (String -> ParseResult a) -> String -> ParseResult 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 a
parser CabalSpecVersion
v Fields Position
values
knownField :: FieldName -> ParsecFieldGrammar s ()
knownField fn :: FieldName
fn = Set FieldName
-> Set FieldName
-> (CabalSpecVersion -> Fields Position -> ParseResult ())
-> ParsecFieldGrammar s ()
forall s a.
Set FieldName
-> Set FieldName
-> (CabalSpecVersion -> Fields Position -> ParseResult 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 (\_ _ -> () -> ParseResult ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ())
hiddenField :: ParsecFieldGrammar s a -> ParsecFieldGrammar s a
hiddenField = ParsecFieldGrammar s a -> ParsecFieldGrammar s a
forall a. a -> a
id
runFieldParser' :: [Position] -> ParsecParser a -> CabalSpecVersion -> FieldLineStream -> ParseResult a
runFieldParser' :: [Position]
-> ParsecParser a
-> CabalSpecVersion
-> FieldLineStream
-> ParseResult a
runFieldParser' inputPoss :: [Position]
inputPoss p :: ParsecParser a
p v :: CabalSpecVersion
v str :: 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' [] "<field>" FieldLineStream
str of
Right (pok :: a
pok, ws :: [PWarning]
ws) -> do
(PWarning -> ParseResult ()) -> [PWarning] -> ParseResult ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ (\(PWarning t :: PWarnType
t pos :: Position
pos w :: String
w) -> Position -> PWarnType -> String -> ParseResult ()
parseWarning (Position -> Position
mapPosition Position
pos) PWarnType
t String
w) [PWarning]
ws
a -> ParseResult a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
pok
Left err :: 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
"or" "unknown parse error" "expecting" "unexpected" "end of input"
(ParseError -> [Message]
P.errorMessages ParseError
err)
Position -> String -> ParseResult a
forall a. Position -> String -> ParseResult a
parseFatalFailure Position
epos (String -> ParseResult a) -> String -> ParseResult a
forall a b. (a -> b) -> a -> b
$ String
msg String -> ShowS
forall a. [a] -> [a] -> [a]
++ "\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 (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 (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 (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 (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 (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
mapPosition :: Position -> Position
mapPosition (Position prow :: Int
prow pcol :: 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
- 1) [Position]
inputPoss where
go :: t -> [Position] -> Position
go _ [] = Position
zeroPos
go _ [Position row :: Int
row col :: 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
- 1)
go n :: t
n (Position row :: Int
row col :: Int
col:_) | t
n t -> t -> Bool
forall a. Ord a => a -> a -> Bool
<= 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
- 1)
go n :: t
n (_:ps :: [Position]
ps) = t -> [Position] -> Position
go (t
n t -> t -> t
forall a. Num a => a -> a -> a
- 1) [Position]
ps
runFieldParser :: Position -> ParsecParser a -> CabalSpecVersion -> [FieldLine Position] -> ParseResult a
runFieldParser :: Position
-> ParsecParser a
-> CabalSpecVersion
-> [FieldLine Position]
-> ParseResult a
runFieldParser pp :: Position
pp p :: ParsecParser a
p v :: CabalSpecVersion
v ls :: [FieldLine Position]
ls = [Position]
-> ParsecParser a
-> CabalSpecVersion
-> FieldLineStream
-> ParseResult a
forall a.
[Position]
-> ParsecParser a
-> CabalSpecVersion
-> FieldLineStream
-> ParseResult 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 pos :: Position
pos _) -> Position
pos) [FieldLine Position]
ls [Position] -> [Position] -> [Position]
forall a. [a] -> [a] -> [a]
++ [Position
pp]
fieldlinesToBS :: [FieldLine ann] -> BS.ByteString
fieldlinesToBS :: [FieldLine ann] -> FieldName
fieldlinesToBS = FieldName -> [FieldName] -> FieldName
BS.intercalate "\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 _ bs :: FieldName
bs) -> FieldName
bs)
fieldlinesToFreeText :: [FieldLine ann] -> String
fieldlinesToFreeText :: [FieldLine ann] -> String
fieldlinesToFreeText [FieldLine _ "."] = "."
fieldlinesToFreeText fls :: [FieldLine ann]
fls = String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate "\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 _ bs :: FieldName
bs)
| String
s String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== "." = ""
| Bool
otherwise = String
s
where
s :: String
s = ShowS
trim (FieldName -> String
fromUTF8BS FieldName
bs)
trim :: String -> String
trim :: ShowS
trim = (Char -> Bool) -> ShowS
forall a. (a -> Bool) -> [a] -> [a]
dropWhile Char -> Bool
isSpace ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> ShowS
forall a. (a -> Bool) -> [a] -> [a]
dropWhileEnd Char -> Bool
isSpace
fieldlinesToFreeText3 :: Position -> [FieldLine Position] -> String
fieldlinesToFreeText3 :: Position -> [FieldLine Position] -> String
fieldlinesToFreeText3 _ [] = ""
fieldlinesToFreeText3 _ [FieldLine _ bs :: FieldName
bs] = FieldName -> String
fromUTF8BS FieldName
bs
fieldlinesToFreeText3 pos :: Position
pos (FieldLine pos1 :: Position
pos1 bs1 :: FieldName
bs1 : fls2 :: [FieldLine Position]
fls2@(FieldLine pos2 :: Position
pos2 _ : _))
| 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
| 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) ' '
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 (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (\a :: Int
a b :: 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 (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (\a :: Int
a b :: 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 col :: Int
col p :: Position
p (FieldLine q :: Position
q bs :: FieldName
bs) =
( Position
q
, Int -> Char -> String
forall a. Int -> a -> [a]
replicate Int
newlines '\n'
String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> Char -> String
forall a. Int -> a -> [a]
replicate Int
indent ' '
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 :: (s -> a -> (s, b)) -> s -> [a] -> [b]
mealy f :: s -> a -> (s, b)
f = s -> [a] -> [b]
go where
go :: s -> [a] -> [b]
go _ [] = []
go s :: s
s (x :: a
x : xs :: [a]
xs) = let ~(s' :: s
s', y :: 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 :: [FieldLine ann] -> FieldLineStream
fieldLinesToStream [] = FieldLineStream
fieldLineStreamEnd
fieldLinesToStream [FieldLine _ bs :: FieldName
bs] = FieldName -> FieldLineStream
FLSLast FieldName
bs
fieldLinesToStream (FieldLine _ bs :: FieldName
bs : fs :: [FieldLine ann]
fs) = FieldName -> FieldLineStream -> FieldLineStream
FLSCons FieldName
bs ([FieldLine ann] -> FieldLineStream
forall ann. [FieldLine ann] -> FieldLineStream
fieldLinesToStream [FieldLine ann]
fs)