{-# LANGUAGE CPP #-}
-----------------------------------------------------------------------------
-- |
-- Module      :  Distribution.Deprecated.ParseUtils
-- Copyright   :  (c) The University of Glasgow 2004
-- License     :  BSD3
--
-- Maintainer  :  cabal-devel@haskell.org
-- Portability :  portable
--
-- Utilities for parsing 'PackageDescription' and 'InstalledPackageInfo'.
--
-- The @.cabal@ file format is not trivial, especially with the introduction
-- of configurations and the section syntax that goes with that. This module
-- has a bunch of parsing functions that is used by the @.cabal@ parser and a
-- couple others. It has the parsing framework code and also little parsers for
-- many of the formats we get in various @.cabal@ file fields, like module
-- names, comma separated lists etc.

-- This module is meant to be local-only to Distribution...

{-# OPTIONS_HADDOCK hide #-}
{-# LANGUAGE Rank2Types #-}
module Distribution.Deprecated.ParseUtils (
        LineNo, PError(..), PWarning(..), locatedErrorMsg, syntaxError, warning,
        runP, runE, ParseResult(..), parseFail, showPWarning,
        Field(..), lineNo,
        FieldDescr(..), readFields,
        parseHaskellString, parseTokenQ,
        parseOptCommaList,
        showFilePath, showToken, showFreeText,
        field, simpleField, listField, listFieldWithSep, spaceListField,
        newLineListField,
        liftField,
        readPToMaybe,

        fieldParsec, simpleFieldParsec,
        listFieldParsec,
        commaListFieldParsec,
        commaNewLineListFieldParsec,

        UnrecFieldParser,
  ) where

import Distribution.Client.Compat.Prelude hiding (get)
import Prelude ()

import Distribution.Deprecated.ReadP as ReadP hiding (get)

import Distribution.Pretty
import Distribution.ReadE
import Distribution.Utils.Generic

import System.FilePath  (normalise)
import Text.PrettyPrint (Doc, punctuate, comma, fsep, sep)
import qualified Text.Read as Read

import qualified Control.Monad.Fail as Fail
import Distribution.Parsec (ParsecParser, parsecLeadingCommaList, parsecLeadingOptCommaList)

import qualified Data.ByteString as BS
import qualified Distribution.Fields as Fields
import qualified Distribution.Fields.Field as Fields
import qualified Distribution.Parsec as Parsec
import qualified Distribution.Fields.LexerMonad as Fields
import qualified Text.Parsec.Error as PE
import qualified Text.Parsec.Pos as PP

-- -----------------------------------------------------------------------------

type LineNo    = Int

data PError = AmbiguousParse String LineNo
            | NoParse String LineNo
            | TabsError LineNo
            | FromString String (Maybe LineNo)
        deriving (PError -> PError -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: PError -> PError -> Bool
$c/= :: PError -> PError -> Bool
== :: PError -> PError -> Bool
$c== :: PError -> PError -> Bool
Eq, LineNo -> PError -> ShowS
[PError] -> ShowS
PError -> String
forall a.
(LineNo -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [PError] -> ShowS
$cshowList :: [PError] -> ShowS
show :: PError -> String
$cshow :: PError -> String
showsPrec :: LineNo -> PError -> ShowS
$cshowsPrec :: LineNo -> PError -> ShowS
Show)

data PWarning = PWarning String
              | UTFWarning LineNo String
        deriving (PWarning -> PWarning -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: PWarning -> PWarning -> Bool
$c/= :: PWarning -> PWarning -> Bool
== :: PWarning -> PWarning -> Bool
$c== :: PWarning -> PWarning -> Bool
Eq, LineNo -> PWarning -> ShowS
[PWarning] -> ShowS
PWarning -> String
forall a.
(LineNo -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [PWarning] -> ShowS
$cshowList :: [PWarning] -> ShowS
show :: PWarning -> String
$cshow :: PWarning -> String
showsPrec :: LineNo -> PWarning -> ShowS
$cshowsPrec :: LineNo -> PWarning -> ShowS
Show)

showPWarning :: FilePath -> PWarning -> String
showPWarning :: String -> PWarning -> String
showPWarning String
fpath (PWarning String
msg) =
  ShowS
normalise String
fpath forall a. [a] -> [a] -> [a]
++ String
": " forall a. [a] -> [a] -> [a]
++ String
msg
showPWarning String
fpath (UTFWarning LineNo
line String
fname) =
  ShowS
normalise String
fpath forall a. [a] -> [a] -> [a]
++ String
":" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show LineNo
line
        forall a. [a] -> [a] -> [a]
++ String
": Invalid UTF-8 text in the '" forall a. [a] -> [a] -> [a]
++ String
fname forall a. [a] -> [a] -> [a]
++ String
"' field."

data ParseResult a = ParseFailed PError | ParseOk [PWarning] a
        deriving LineNo -> ParseResult a -> ShowS
forall a. Show a => LineNo -> ParseResult a -> ShowS
forall a. Show a => [ParseResult a] -> ShowS
forall a. Show a => ParseResult a -> String
forall a.
(LineNo -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ParseResult a] -> ShowS
$cshowList :: forall a. Show a => [ParseResult a] -> ShowS
show :: ParseResult a -> String
$cshow :: forall a. Show a => ParseResult a -> String
showsPrec :: LineNo -> ParseResult a -> ShowS
$cshowsPrec :: forall a. Show a => LineNo -> ParseResult a -> ShowS
Show

instance Functor ParseResult where
        fmap :: forall a b. (a -> b) -> ParseResult a -> ParseResult b
fmap a -> b
_ (ParseFailed PError
err) = forall a. PError -> ParseResult a
ParseFailed PError
err
        fmap a -> b
f (ParseOk [PWarning]
ws a
x) = forall a. [PWarning] -> a -> ParseResult a
ParseOk [PWarning]
ws forall a b. (a -> b) -> a -> b
$ a -> b
f a
x

instance Applicative ParseResult where
        pure :: forall a. a -> ParseResult a
pure = forall a. [PWarning] -> a -> ParseResult a
ParseOk []
        <*> :: forall a b. ParseResult (a -> b) -> ParseResult a -> ParseResult b
(<*>) = forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
ap


instance Monad ParseResult where
        return :: forall a. a -> ParseResult a
return = forall (f :: * -> *) a. Applicative f => a -> f a
pure
        ParseFailed PError
err >>= :: forall a b. ParseResult a -> (a -> ParseResult b) -> ParseResult b
>>= a -> ParseResult b
_ = forall a. PError -> ParseResult a
ParseFailed PError
err
        ParseOk [PWarning]
ws a
x >>= a -> ParseResult b
f = case a -> ParseResult b
f a
x of
                               ParseFailed PError
err -> forall a. PError -> ParseResult a
ParseFailed PError
err
                               ParseOk [PWarning]
ws' b
x' -> forall a. [PWarning] -> a -> ParseResult a
ParseOk ([PWarning]
ws'forall a. [a] -> [a] -> [a]
++[PWarning]
ws) b
x'
#if !(MIN_VERSION_base(4,9,0))
        fail = parseResultFail
#elif !(MIN_VERSION_base(4,13,0))
        fail = Fail.fail
#endif

instance Foldable ParseResult where
  foldMap :: forall m a. Monoid m => (a -> m) -> ParseResult a -> m
foldMap a -> m
_ (ParseFailed PError
_ ) = forall a. Monoid a => a
mempty
  foldMap a -> m
f (ParseOk [PWarning]
_ a
x) = a -> m
f a
x

instance Traversable ParseResult where
  traverse :: forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> ParseResult a -> f (ParseResult b)
traverse a -> f b
_ (ParseFailed PError
err) = forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a. PError -> ParseResult a
ParseFailed PError
err)
  traverse a -> f b
f (ParseOk [PWarning]
ws a
x) = forall a. [PWarning] -> a -> ParseResult a
ParseOk [PWarning]
ws forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> a -> f b
f a
x


instance Fail.MonadFail ParseResult where
        fail :: forall a. String -> ParseResult a
fail = forall a. String -> ParseResult a
parseResultFail

parseResultFail :: String -> ParseResult a
parseResultFail :: forall a. String -> ParseResult a
parseResultFail String
s = forall a. PError -> ParseResult a
parseFail (String -> Maybe LineNo -> PError
FromString String
s forall a. Maybe a
Nothing)

parseFail :: PError -> ParseResult a
parseFail :: forall a. PError -> ParseResult a
parseFail = forall a. PError -> ParseResult a
ParseFailed

runP :: LineNo -> String -> ReadP a a -> String -> ParseResult a
runP :: forall a. LineNo -> String -> ReadP a a -> String -> ParseResult a
runP LineNo
line String
fieldname ReadP a a
p String
s =
  case [ a
x | (a
x,String
"") <- [(a, String)]
results ] of
    [a
a] -> forall a. [PWarning] -> a -> ParseResult a
ParseOk (LineNo -> String -> String -> [PWarning]
utf8Warnings LineNo
line String
fieldname String
s) a
a
    --TODO: what is this double parse thing all about?
    --      Can't we just do the all isSpace test the first time?
    []  -> case [ a
x | (a
x,String
ys) <- [(a, String)]
results, forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Char -> Bool
isSpace String
ys ] of
             [a
a] -> forall a. [PWarning] -> a -> ParseResult a
ParseOk (LineNo -> String -> String -> [PWarning]
utf8Warnings LineNo
line String
fieldname String
s) a
a
             []  -> forall a. PError -> ParseResult a
ParseFailed (String -> LineNo -> PError
NoParse String
fieldname LineNo
line)
             [a]
_   -> forall a. PError -> ParseResult a
ParseFailed (String -> LineNo -> PError
AmbiguousParse String
fieldname LineNo
line)
    [a]
_   -> forall a. PError -> ParseResult a
ParseFailed (String -> LineNo -> PError
AmbiguousParse String
fieldname LineNo
line)
  where results :: [(a, String)]
results = forall a. ReadP a a -> ReadS a
readP_to_S ReadP a a
p String
s

runE :: LineNo -> String -> ReadE a -> String -> ParseResult a
runE :: forall a. LineNo -> String -> ReadE a -> String -> ParseResult a
runE LineNo
line String
fieldname ReadE a
p String
s =
    case forall a. ReadE a -> String -> Either String a
runReadE ReadE a
p String
s of
      Right a
a -> forall a. [PWarning] -> a -> ParseResult a
ParseOk (LineNo -> String -> String -> [PWarning]
utf8Warnings LineNo
line String
fieldname String
s) a
a
      Left  String
e -> forall a. LineNo -> String -> ParseResult a
syntaxError LineNo
line forall a b. (a -> b) -> a -> b
$
        String
"Parse of field '" forall a. [a] -> [a] -> [a]
++ String
fieldname forall a. [a] -> [a] -> [a]
++ String
"' failed (" forall a. [a] -> [a] -> [a]
++ String
e forall a. [a] -> [a] -> [a]
++ String
"): " forall a. [a] -> [a] -> [a]
++ String
s

utf8Warnings :: LineNo -> String -> String -> [PWarning]
utf8Warnings :: LineNo -> String -> String -> [PWarning]
utf8Warnings LineNo
line String
fieldname String
s =
  forall a. LineNo -> [a] -> [a]
take LineNo
1 [ LineNo -> String -> PWarning
UTFWarning LineNo
n String
fieldname
         | (LineNo
n,String
l) <- forall a b. [a] -> [b] -> [(a, b)]
zip [LineNo
line..] (String -> [String]
lines String
s)
         , Char
'\xfffd' forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` String
l ]

locatedErrorMsg :: PError -> (Maybe LineNo, String)
locatedErrorMsg :: PError -> (Maybe LineNo, String)
locatedErrorMsg (AmbiguousParse String
f LineNo
n) = (forall a. a -> Maybe a
Just LineNo
n,
                                        String
"Ambiguous parse in field '"forall a. [a] -> [a] -> [a]
++String
fforall a. [a] -> [a] -> [a]
++String
"'.")
locatedErrorMsg (NoParse String
f LineNo
n)        = (forall a. a -> Maybe a
Just LineNo
n,
                                        String
"Parse of field '"forall a. [a] -> [a] -> [a]
++String
fforall a. [a] -> [a] -> [a]
++String
"' failed.")
locatedErrorMsg (TabsError LineNo
n)        = (forall a. a -> Maybe a
Just LineNo
n, String
"Tab used as indentation.")
locatedErrorMsg (FromString String
s Maybe LineNo
n)     = (Maybe LineNo
n, String
s)

syntaxError :: LineNo -> String -> ParseResult a
syntaxError :: forall a. LineNo -> String -> ParseResult a
syntaxError LineNo
n String
s = forall a. PError -> ParseResult a
ParseFailed forall a b. (a -> b) -> a -> b
$ String -> Maybe LineNo -> PError
FromString String
s (forall a. a -> Maybe a
Just LineNo
n)


warning :: String -> ParseResult ()
warning :: String -> ParseResult ()
warning String
s = forall a. [PWarning] -> a -> ParseResult a
ParseOk [String -> PWarning
PWarning String
s] ()

-- | Field descriptor.  The parameter @a@ parameterizes over where the field's
--   value is stored in.
data FieldDescr a
  = FieldDescr
      { forall a. FieldDescr a -> String
fieldName     :: String
      , forall a. FieldDescr a -> a -> Doc
fieldGet      :: a -> Doc
      , forall a. FieldDescr a -> LineNo -> String -> a -> ParseResult a
fieldSet      :: LineNo -> String -> a -> ParseResult a
        -- ^ @fieldSet n str x@ Parses the field value from the given input
        -- string @str@ and stores the result in @x@ if the parse was
        -- successful.  Otherwise, reports an error on line number @n@.
      }

field :: String -> (a -> Doc) -> ReadP a a -> FieldDescr a
field :: forall a. String -> (a -> Doc) -> ReadP a a -> FieldDescr a
field String
name a -> Doc
showF ReadP a a
readF =
  forall a.
String
-> (a -> Doc)
-> (LineNo -> String -> a -> ParseResult a)
-> FieldDescr a
FieldDescr String
name a -> Doc
showF (\LineNo
line String
val a
_st -> forall a. LineNo -> String -> ReadP a a -> String -> ParseResult a
runP LineNo
line String
name ReadP a a
readF String
val)

fieldParsec :: String -> (a -> Doc) -> ParsecParser a -> FieldDescr a
fieldParsec :: forall a. String -> (a -> Doc) -> ParsecParser a -> FieldDescr a
fieldParsec String
name a -> Doc
showF ParsecParser a
readF =
  forall a.
String
-> (a -> Doc)
-> (LineNo -> String -> a -> ParseResult a)
-> FieldDescr a
FieldDescr String
name a -> Doc
showF forall a b. (a -> b) -> a -> b
$ \LineNo
line String
val a
_st -> case forall a. ParsecParser a -> String -> Either String a
explicitEitherParsec ParsecParser a
readF String
val of
    Left String
err -> forall a. PError -> ParseResult a
ParseFailed (String -> Maybe LineNo -> PError
FromString String
err (forall a. a -> Maybe a
Just LineNo
line))
    Right a
x  -> forall a. [PWarning] -> a -> ParseResult a
ParseOk [] a
x

-- Lift a field descriptor storing into an 'a' to a field descriptor storing
-- into a 'b'.
liftField :: (b -> a) -> (a -> b -> b) -> FieldDescr a -> FieldDescr b
liftField :: forall b a.
(b -> a) -> (a -> b -> b) -> FieldDescr a -> FieldDescr b
liftField b -> a
get a -> b -> b
set (FieldDescr String
name a -> Doc
showF LineNo -> String -> a -> ParseResult a
parseF)
 = forall a.
String
-> (a -> Doc)
-> (LineNo -> String -> a -> ParseResult a)
-> FieldDescr a
FieldDescr String
name (a -> Doc
showF forall b c a. (b -> c) -> (a -> b) -> a -> c
. b -> a
get)
        (\LineNo
line String
str b
b -> do
            a
a <- LineNo -> String -> a -> ParseResult a
parseF LineNo
line String
str (b -> a
get b
b)
            forall (m :: * -> *) a. Monad m => a -> m a
return (a -> b -> b
set a
a b
b))

-- Parser combinator for simple fields.  Takes a field name, a pretty printer,
-- a parser function, an accessor, and a setter, returns a FieldDescr over the
-- compoid structure.
simpleField :: String -> (a -> Doc) -> ReadP a a
            -> (b -> a) -> (a -> b -> b) -> FieldDescr b
simpleField :: forall a b.
String
-> (a -> Doc)
-> ReadP a a
-> (b -> a)
-> (a -> b -> b)
-> FieldDescr b
simpleField String
name a -> Doc
showF ReadP a a
readF b -> a
get a -> b -> b
set
  = forall b a.
(b -> a) -> (a -> b -> b) -> FieldDescr a -> FieldDescr b
liftField b -> a
get a -> b -> b
set forall a b. (a -> b) -> a -> b
$ forall a. String -> (a -> Doc) -> ReadP a a -> FieldDescr a
field String
name a -> Doc
showF ReadP a a
readF

simpleFieldParsec :: String -> (a -> Doc) -> ParsecParser a
            -> (b -> a) -> (a -> b -> b) -> FieldDescr b
simpleFieldParsec :: forall a b.
String
-> (a -> Doc)
-> ParsecParser a
-> (b -> a)
-> (a -> b -> b)
-> FieldDescr b
simpleFieldParsec String
name a -> Doc
showF ParsecParser a
readF b -> a
get a -> b -> b
set
  = forall b a.
(b -> a) -> (a -> b -> b) -> FieldDescr a -> FieldDescr b
liftField b -> a
get a -> b -> b
set forall a b. (a -> b) -> a -> b
$ forall a. String -> (a -> Doc) -> ParsecParser a -> FieldDescr a
fieldParsec String
name a -> Doc
showF ParsecParser a
readF

commaListFieldWithSepParsec :: Separator -> String -> (a -> Doc) -> ParsecParser a
                      -> (b -> [a]) -> ([a] -> b -> b) -> FieldDescr b
commaListFieldWithSepParsec :: forall a b.
Separator
-> String
-> (a -> Doc)
-> ParsecParser a
-> (b -> [a])
-> ([a] -> b -> b)
-> FieldDescr b
commaListFieldWithSepParsec Separator
separator String
name a -> Doc
showF ParsecParser a
readF b -> [a]
get [a] -> b -> b
set =
   forall b a.
(b -> a) -> (a -> b -> b) -> FieldDescr a -> FieldDescr b
liftField b -> [a]
get [a] -> b -> b
set' forall a b. (a -> b) -> a -> b
$
     forall a. String -> (a -> Doc) -> ParsecParser a -> FieldDescr a
fieldParsec String
name [a] -> Doc
showF' (forall (m :: * -> *) a. CabalParsing m => m a -> m [a]
parsecLeadingCommaList ParsecParser a
readF)
   where
     set' :: [a] -> b -> b
set' [a]
xs b
b = [a] -> b -> b
set (b -> [a]
get b
b forall a. [a] -> [a] -> [a]
++ [a]
xs) b
b
     showF' :: [a] -> Doc
showF'    = Separator
separator forall b c a. (b -> c) -> (a -> b) -> a -> c
. Doc -> [Doc] -> [Doc]
punctuate Doc
comma forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map a -> Doc
showF

commaListFieldParsec :: String -> (a -> Doc) -> ParsecParser a
                 -> (b -> [a]) -> ([a] -> b -> b) -> FieldDescr b
commaListFieldParsec :: forall a b.
String
-> (a -> Doc)
-> ParsecParser a
-> (b -> [a])
-> ([a] -> b -> b)
-> FieldDescr b
commaListFieldParsec = forall a b.
Separator
-> String
-> (a -> Doc)
-> ParsecParser a
-> (b -> [a])
-> ([a] -> b -> b)
-> FieldDescr b
commaListFieldWithSepParsec Separator
fsep

commaNewLineListFieldParsec
    :: String -> (a -> Doc) ->  ParsecParser a
    -> (b -> [a]) -> ([a] -> b -> b) -> FieldDescr b
commaNewLineListFieldParsec :: forall a b.
String
-> (a -> Doc)
-> ParsecParser a
-> (b -> [a])
-> ([a] -> b -> b)
-> FieldDescr b
commaNewLineListFieldParsec = forall a b.
Separator
-> String
-> (a -> Doc)
-> ParsecParser a
-> (b -> [a])
-> ([a] -> b -> b)
-> FieldDescr b
commaListFieldWithSepParsec Separator
sep

spaceListField :: String -> (a -> Doc) -> ReadP [a] a
                 -> (b -> [a]) -> ([a] -> b -> b) -> FieldDescr b
spaceListField :: forall a b.
String
-> (a -> Doc)
-> ReadP [a] a
-> (b -> [a])
-> ([a] -> b -> b)
-> FieldDescr b
spaceListField String
name a -> Doc
showF ReadP [a] a
readF b -> [a]
get [a] -> b -> b
set =
  forall b a.
(b -> a) -> (a -> b -> b) -> FieldDescr a -> FieldDescr b
liftField b -> [a]
get [a] -> b -> b
set' forall a b. (a -> b) -> a -> b
$
    forall a. String -> (a -> Doc) -> ReadP a a -> FieldDescr a
field String
name [a] -> Doc
showF' (forall r a. ReadP r a -> ReadP r [a]
parseSpaceList ReadP [a] a
readF)
  where
    set' :: [a] -> b -> b
set' [a]
xs b
b = [a] -> b -> b
set (b -> [a]
get b
b forall a. [a] -> [a] -> [a]
++ [a]
xs) b
b
    showF' :: [a] -> Doc
showF'    = Separator
fsep forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map a -> Doc
showF

-- this is a different definition from listField, like
-- commaNewLineListField it pretty prints on multiple lines
newLineListField :: String -> (a -> Doc) -> ReadP [a] a
                 -> (b -> [a]) -> ([a] -> b -> b) -> FieldDescr b
newLineListField :: forall a b.
String
-> (a -> Doc)
-> ReadP [a] a
-> (b -> [a])
-> ([a] -> b -> b)
-> FieldDescr b
newLineListField = forall a b.
Separator
-> String
-> (a -> Doc)
-> ReadP [a] a
-> (b -> [a])
-> ([a] -> b -> b)
-> FieldDescr b
listFieldWithSep Separator
sep

listFieldWithSep :: Separator -> String -> (a -> Doc) -> ReadP [a] a
                 -> (b -> [a]) -> ([a] -> b -> b) -> FieldDescr b
listFieldWithSep :: forall a b.
Separator
-> String
-> (a -> Doc)
-> ReadP [a] a
-> (b -> [a])
-> ([a] -> b -> b)
-> FieldDescr b
listFieldWithSep Separator
separator String
name a -> Doc
showF ReadP [a] a
readF b -> [a]
get [a] -> b -> b
set =
  forall b a.
(b -> a) -> (a -> b -> b) -> FieldDescr a -> FieldDescr b
liftField b -> [a]
get [a] -> b -> b
set' forall a b. (a -> b) -> a -> b
$
    forall a. String -> (a -> Doc) -> ReadP a a -> FieldDescr a
field String
name [a] -> Doc
showF' (forall r a. ReadP r a -> ReadP r [a]
parseOptCommaList ReadP [a] a
readF)
  where
    set' :: [a] -> b -> b
set' [a]
xs b
b = [a] -> b -> b
set (b -> [a]
get b
b forall a. [a] -> [a] -> [a]
++ [a]
xs) b
b
    showF' :: [a] -> Doc
showF'    = Separator
separator forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map a -> Doc
showF

listFieldWithSepParsec :: Separator -> String -> (a -> Doc) -> ParsecParser a
                 -> (b -> [a]) -> ([a] -> b -> b) -> FieldDescr b
listFieldWithSepParsec :: forall a b.
Separator
-> String
-> (a -> Doc)
-> ParsecParser a
-> (b -> [a])
-> ([a] -> b -> b)
-> FieldDescr b
listFieldWithSepParsec Separator
separator String
name a -> Doc
showF ParsecParser a
readF b -> [a]
get [a] -> b -> b
set =
  forall b a.
(b -> a) -> (a -> b -> b) -> FieldDescr a -> FieldDescr b
liftField b -> [a]
get [a] -> b -> b
set' forall a b. (a -> b) -> a -> b
$
    forall a. String -> (a -> Doc) -> ParsecParser a -> FieldDescr a
fieldParsec String
name [a] -> Doc
showF' (forall (m :: * -> *) a. CabalParsing m => m a -> m [a]
parsecLeadingOptCommaList ParsecParser a
readF)
  where
    set' :: [a] -> b -> b
set' [a]
xs b
b = [a] -> b -> b
set (b -> [a]
get b
b forall a. [a] -> [a] -> [a]
++ [a]
xs) b
b
    showF' :: [a] -> Doc
showF'    = Separator
separator forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map a -> Doc
showF

listField :: String -> (a -> Doc) -> ReadP [a] a
          -> (b -> [a]) -> ([a] -> b -> b) -> FieldDescr b
listField :: forall a b.
String
-> (a -> Doc)
-> ReadP [a] a
-> (b -> [a])
-> ([a] -> b -> b)
-> FieldDescr b
listField = forall a b.
Separator
-> String
-> (a -> Doc)
-> ReadP [a] a
-> (b -> [a])
-> ([a] -> b -> b)
-> FieldDescr b
listFieldWithSep Separator
fsep

listFieldParsec
    :: String -> (a -> Doc) -> ParsecParser a
    -> (b -> [a]) -> ([a] -> b -> b) -> FieldDescr b
listFieldParsec :: forall a b.
String
-> (a -> Doc)
-> ParsecParser a
-> (b -> [a])
-> ([a] -> b -> b)
-> FieldDescr b
listFieldParsec = forall a b.
Separator
-> String
-> (a -> Doc)
-> ParsecParser a
-> (b -> [a])
-> ([a] -> b -> b)
-> FieldDescr b
listFieldWithSepParsec Separator
fsep

-- | The type of a function which, given a name-value pair of an
--   unrecognized field, and the current structure being built,
--   decides whether to incorporate the unrecognized field
--   (by returning  Just x, where x is a possibly modified version
--   of the structure being built), or not (by returning Nothing).
type UnrecFieldParser a = (String,String) -> a -> Maybe a

------------------------------------------------------------------------------

-- The data type for our three syntactic categories
data Field
    = F LineNo String String
      -- ^ A regular @<property>: <value>@ field
    | Section LineNo String String [Field]
      -- ^ A section with a name and possible parameter.  The syntactic
      -- structure is:
      --
      -- @
      --   <sectionname> <arg> {
      --     <field>*
      --   }
      -- @
      deriving (LineNo -> Field -> ShowS
[Field] -> ShowS
Field -> String
forall a.
(LineNo -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Field] -> ShowS
$cshowList :: [Field] -> ShowS
show :: Field -> String
$cshow :: Field -> String
showsPrec :: LineNo -> Field -> ShowS
$cshowsPrec :: LineNo -> Field -> ShowS
Show
               ,Field -> Field -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Field -> Field -> Bool
$c/= :: Field -> Field -> Bool
== :: Field -> Field -> Bool
$c== :: Field -> Field -> Bool
Eq)   -- for testing

lineNo :: Field -> LineNo
lineNo :: Field -> LineNo
lineNo (F LineNo
n String
_ String
_) = LineNo
n
lineNo (Section LineNo
n String
_ String
_ [Field]
_) = LineNo
n

readFields :: BS.ByteString -> ParseResult [Field]
readFields :: ByteString -> ParseResult [Field]
readFields ByteString
input = case ByteString -> Either ParseError ([Field Position], [LexWarning])
Fields.readFields' ByteString
input of
    Right ([Field Position]
fs, [LexWarning]
ws) -> forall a. [PWarning] -> a -> ParseResult a
ParseOk
        [ String -> PWarning
PWarning String
msg | Fields.PWarning PWarnType
_ Position
_ String
msg <- [LexWarning] -> [PWarning]
Fields.toPWarnings [LexWarning]
ws ]
        ([Field Position] -> [Field]
legacyFields [Field Position]
fs)
    Left ParseError
perr      -> forall a. PError -> ParseResult a
ParseFailed forall a b. (a -> b) -> a -> b
$ String -> LineNo -> PError
NoParse
        (String
-> String -> String -> String -> String -> [Message] -> String
PE.showErrorMessages
            String
"or" String
"unknown parse error" String
"expecting" String
"unexpected" String
"end of file"
            (ParseError -> [Message]
PE.errorMessages ParseError
perr))
        (SourcePos -> LineNo
PP.sourceLine SourcePos
pos)
      where
        pos :: SourcePos
pos = ParseError -> SourcePos
PE.errorPos ParseError
perr

legacyFields :: [Fields.Field Parsec.Position] -> [Field]
legacyFields :: [Field Position] -> [Field]
legacyFields = forall a b. (a -> b) -> [a] -> [b]
map Field Position -> Field
legacyField

legacyField :: Fields.Field Parsec.Position -> Field
legacyField :: Field Position -> Field
legacyField (Fields.Field (Fields.Name Position
pos ByteString
name) [FieldLine Position]
fls) =
    LineNo -> String -> String -> Field
F (Position -> LineNo
posToLineNo Position
pos) (ByteString -> String
fromUTF8BS ByteString
name) (forall ann. [FieldLine ann] -> String
Fields.fieldLinesToString [FieldLine Position]
fls)
legacyField (Fields.Section (Fields.Name Position
pos ByteString
name) [SectionArg Position]
args [Field Position]
fs) =
    LineNo -> String -> String -> [Field] -> Field
Section (Position -> LineNo
posToLineNo Position
pos) (ByteString -> String
fromUTF8BS ByteString
name) (forall ann. [SectionArg ann] -> String
Fields.sectionArgsToString [SectionArg Position]
args) ([Field Position] -> [Field]
legacyFields [Field Position]
fs)

posToLineNo :: Parsec.Position -> LineNo
posToLineNo :: Position -> LineNo
posToLineNo (Parsec.Position LineNo
row LineNo
_) = LineNo
row

------------------------------------------------------------------------------

-- urgh, we can't define optQuotes :: ReadP r a -> ReadP r a
-- because the "compat" version of ReadP isn't quite powerful enough.  In
-- particular, the type of <++ is ReadP r r -> ReadP r a -> ReadP r a
-- Hence the trick above to make 'lic' polymorphic.

-- Different than the naive version. it turns out Read instance for String accepts
-- the ['a', 'b'] syntax, which we do not want. In particular it messes
-- up any token starting with [].
parseHaskellString :: ReadP r String
parseHaskellString :: forall r. ReadP r String
parseHaskellString =
  forall a r. ReadS a -> ReadP r a
readS_to_P forall a b. (a -> b) -> a -> b
$
    forall a. ReadPrec a -> LineNo -> ReadS a
Read.readPrec_to_S (do Read.String String
s <- ReadPrec Lexeme
Read.lexP; forall (m :: * -> *) a. Monad m => a -> m a
return String
s) LineNo
0

parseTokenQ :: ReadP r String
parseTokenQ :: forall r. ReadP r String
parseTokenQ = forall r. ReadP r String
parseHaskellString forall a r. ReadP a a -> ReadP r a -> ReadP r a
<++ forall r. (Char -> Bool) -> ReadP r String
munch1 (\Char
x -> Bool -> Bool
not (Char -> Bool
isSpace Char
x) Bool -> Bool -> Bool
&& Char
x forall a. Eq a => a -> a -> Bool
/= Char
',')

parseSpaceList :: ReadP r a -- ^The parser for the stuff between commas
               -> ReadP r [a]
parseSpaceList :: forall r a. ReadP r a -> ReadP r [a]
parseSpaceList ReadP r a
p = forall r a sep. ReadP r a -> ReadP r sep -> ReadP r [a]
sepBy ReadP r a
p forall r. ReadP r ()
skipSpaces

-- This version avoid parse ambiguity for list element parsers
-- that have multiple valid parses of prefixes.
parseOptCommaList :: ReadP r a -> ReadP r [a]
parseOptCommaList :: forall r a. ReadP r a -> ReadP r [a]
parseOptCommaList ReadP r a
p = forall r a sep. ReadP r a -> ReadP r sep -> ReadP r [a]
sepBy ReadP r a
p forall r. ReadP r ()
localSep
  where
    -- The separator must not be empty or it introduces ambiguity
    localSep :: ReadP r ()
localSep = (forall r. ReadP r ()
skipSpaces forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall r. Char -> ReadP r Char
char Char
',' forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall r. ReadP r ()
skipSpaces)
      forall r a. ReadP r a -> ReadP r a -> ReadP r a
+++ (forall r. (Char -> Bool) -> ReadP r Char
satisfy Char -> Bool
isSpace forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall r. ReadP r ()
skipSpaces)

readPToMaybe :: ReadP a a -> String -> Maybe a
readPToMaybe :: forall a. ReadP a a -> String -> Maybe a
readPToMaybe ReadP a a
p String
str = forall a. [a] -> Maybe a
listToMaybe [ a
r | (a
r,String
s) <- forall a. ReadP a a -> ReadS a
readP_to_S ReadP a a
p String
str
                                     , forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Char -> Bool
isSpace String
s ]