{-# 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
(PError -> PError -> Bool)
-> (PError -> PError -> Bool) -> Eq PError
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, Int -> PError -> ShowS
[PError] -> ShowS
PError -> String
(Int -> PError -> ShowS)
-> (PError -> String) -> ([PError] -> ShowS) -> Show PError
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [PError] -> ShowS
$cshowList :: [PError] -> ShowS
show :: PError -> String
$cshow :: PError -> String
showsPrec :: Int -> PError -> ShowS
$cshowsPrec :: Int -> PError -> ShowS
Show)

data PWarning = PWarning String
              | UTFWarning LineNo String
        deriving (PWarning -> PWarning -> Bool
(PWarning -> PWarning -> Bool)
-> (PWarning -> PWarning -> Bool) -> Eq PWarning
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, Int -> PWarning -> ShowS
[PWarning] -> ShowS
PWarning -> String
(Int -> PWarning -> ShowS)
-> (PWarning -> String) -> ([PWarning] -> ShowS) -> Show PWarning
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [PWarning] -> ShowS
$cshowList :: [PWarning] -> ShowS
show :: PWarning -> String
$cshow :: PWarning -> String
showsPrec :: Int -> PWarning -> ShowS
$cshowsPrec :: Int -> PWarning -> ShowS
Show)

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

data ParseResult a = ParseFailed PError | ParseOk [PWarning] a
        deriving Int -> ParseResult a -> ShowS
[ParseResult a] -> ShowS
ParseResult a -> String
(Int -> ParseResult a -> ShowS)
-> (ParseResult a -> String)
-> ([ParseResult a] -> ShowS)
-> Show (ParseResult a)
forall a. Show a => Int -> ParseResult a -> ShowS
forall a. Show a => [ParseResult a] -> ShowS
forall a. Show a => ParseResult a -> String
forall a.
(Int -> 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 :: Int -> ParseResult a -> ShowS
$cshowsPrec :: forall a. Show a => Int -> ParseResult a -> ShowS
Show

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

instance Applicative ParseResult where
        pure :: a -> ParseResult a
pure = [PWarning] -> a -> ParseResult a
forall a. [PWarning] -> a -> ParseResult a
ParseOk []
        <*> :: ParseResult (a -> b) -> ParseResult a -> ParseResult 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 :: a -> ParseResult a
return = a -> ParseResult a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
        ParseFailed PError
err >>= :: ParseResult a -> (a -> ParseResult b) -> ParseResult b
>>= a -> ParseResult b
_ = PError -> 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 -> PError -> ParseResult b
forall a. PError -> ParseResult a
ParseFailed PError
err
                               ParseOk [PWarning]
ws' b
x' -> [PWarning] -> b -> ParseResult b
forall a. [PWarning] -> a -> ParseResult a
ParseOk ([PWarning]
ws'[PWarning] -> [PWarning] -> [PWarning]
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 :: (a -> m) -> ParseResult a -> m
foldMap a -> m
_ (ParseFailed PError
_ ) = m
forall a. Monoid a => a
mempty
  foldMap a -> m
f (ParseOk [PWarning]
_ a
x) = a -> m
f a
x

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


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

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

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

runP :: LineNo -> String -> ReadP a a -> String -> ParseResult a
runP :: Int -> String -> ReadP a a -> String -> ParseResult a
runP Int
line String
fieldname ReadP a a
p String
s =
  case [ a
x | (a
x,String
"") <- [(a, String)]
results ] of
    [a
a] -> [PWarning] -> a -> ParseResult a
forall a. [PWarning] -> a -> ParseResult a
ParseOk (Int -> String -> String -> [PWarning]
utf8Warnings Int
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, (Char -> Bool) -> String -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Char -> Bool
isSpace String
ys ] of
             [a
a] -> [PWarning] -> a -> ParseResult a
forall a. [PWarning] -> a -> ParseResult a
ParseOk (Int -> String -> String -> [PWarning]
utf8Warnings Int
line String
fieldname String
s) a
a
             []  -> PError -> ParseResult a
forall a. PError -> ParseResult a
ParseFailed (String -> Int -> PError
NoParse String
fieldname Int
line)
             [a]
_   -> PError -> ParseResult a
forall a. PError -> ParseResult a
ParseFailed (String -> Int -> PError
AmbiguousParse String
fieldname Int
line)
    [a]
_   -> PError -> ParseResult a
forall a. PError -> ParseResult a
ParseFailed (String -> Int -> PError
AmbiguousParse String
fieldname Int
line)
  where results :: [(a, String)]
results = ReadP a a -> ReadS a
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 :: Int -> String -> ReadE a -> String -> ParseResult a
runE Int
line String
fieldname ReadE a
p String
s =
    case ReadE a -> String -> Either String a
forall a. ReadE a -> String -> Either String a
runReadE ReadE a
p String
s of
      Right a
a -> [PWarning] -> a -> ParseResult a
forall a. [PWarning] -> a -> ParseResult a
ParseOk (Int -> String -> String -> [PWarning]
utf8Warnings Int
line String
fieldname String
s) a
a
      Left  String
e -> Int -> String -> ParseResult a
forall a. Int -> String -> ParseResult a
syntaxError Int
line (String -> ParseResult a) -> String -> ParseResult a
forall a b. (a -> b) -> a -> b
$
        String
"Parse of field '" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
fieldname String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"' failed (" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
e String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"): " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
s

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

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

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


warning :: String -> ParseResult ()
warning :: String -> ParseResult ()
warning String
s = [PWarning] -> () -> ParseResult ()
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
      { FieldDescr a -> String
fieldName     :: String
      , FieldDescr a -> a -> Doc
fieldGet      :: a -> Doc
      , FieldDescr a -> Int -> 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 :: String -> (a -> Doc) -> ReadP a a -> FieldDescr a
field String
name a -> Doc
showF ReadP a a
readF =
  String
-> (a -> Doc)
-> (Int -> String -> a -> ParseResult a)
-> FieldDescr a
forall a.
String
-> (a -> Doc)
-> (Int -> String -> a -> ParseResult a)
-> FieldDescr a
FieldDescr String
name a -> Doc
showF (\Int
line String
val a
_st -> Int -> String -> ReadP a a -> String -> ParseResult a
forall a. Int -> String -> ReadP a a -> String -> ParseResult a
runP Int
line String
name ReadP a a
readF String
val)

fieldParsec :: String -> (a -> Doc) -> ParsecParser a -> FieldDescr a
fieldParsec :: String -> (a -> Doc) -> ParsecParser a -> FieldDescr a
fieldParsec String
name a -> Doc
showF ParsecParser a
readF =
  String
-> (a -> Doc)
-> (Int -> String -> a -> ParseResult a)
-> FieldDescr a
forall a.
String
-> (a -> Doc)
-> (Int -> String -> a -> ParseResult a)
-> FieldDescr a
FieldDescr String
name a -> Doc
showF ((Int -> String -> a -> ParseResult a) -> FieldDescr a)
-> (Int -> String -> a -> ParseResult a) -> FieldDescr a
forall a b. (a -> b) -> a -> b
$ \Int
line String
val a
_st -> case ParsecParser a -> String -> Either String a
forall a. ParsecParser a -> String -> Either String a
explicitEitherParsec ParsecParser a
readF String
val of
    Left String
err -> PError -> ParseResult a
forall a. PError -> ParseResult a
ParseFailed (String -> Maybe Int -> PError
FromString String
err (Int -> Maybe Int
forall a. a -> Maybe a
Just Int
line))
    Right a
x  -> [PWarning] -> a -> ParseResult a
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 :: (b -> a) -> (a -> b -> b) -> FieldDescr a -> FieldDescr b
liftField b -> a
get a -> b -> b
set (FieldDescr String
name a -> Doc
showF Int -> String -> a -> ParseResult a
parseF)
 = String
-> (b -> Doc)
-> (Int -> String -> b -> ParseResult b)
-> FieldDescr b
forall a.
String
-> (a -> Doc)
-> (Int -> String -> a -> ParseResult a)
-> FieldDescr a
FieldDescr String
name (a -> Doc
showF (a -> Doc) -> (b -> a) -> b -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. b -> a
get)
        (\Int
line String
str b
b -> do
            a
a <- Int -> String -> a -> ParseResult a
parseF Int
line String
str (b -> a
get b
b)
            b -> ParseResult 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 :: 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
  = (b -> a) -> (a -> b -> b) -> FieldDescr a -> FieldDescr b
forall b a.
(b -> a) -> (a -> b -> b) -> FieldDescr a -> FieldDescr b
liftField b -> a
get a -> b -> b
set (FieldDescr a -> FieldDescr b) -> FieldDescr a -> FieldDescr b
forall a b. (a -> b) -> a -> b
$ String -> (a -> Doc) -> ReadP a a -> FieldDescr a
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 :: 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
  = (b -> a) -> (a -> b -> b) -> FieldDescr a -> FieldDescr b
forall b a.
(b -> a) -> (a -> b -> b) -> FieldDescr a -> FieldDescr b
liftField b -> a
get a -> b -> b
set (FieldDescr a -> FieldDescr b) -> FieldDescr a -> FieldDescr b
forall a b. (a -> b) -> a -> b
$ String -> (a -> Doc) -> ParsecParser a -> FieldDescr a
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 :: 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 =
   (b -> [a]) -> ([a] -> b -> b) -> FieldDescr [a] -> FieldDescr b
forall b a.
(b -> a) -> (a -> b -> b) -> FieldDescr a -> FieldDescr b
liftField b -> [a]
get [a] -> b -> b
set' (FieldDescr [a] -> FieldDescr b) -> FieldDescr [a] -> FieldDescr b
forall a b. (a -> b) -> a -> b
$
     String -> ([a] -> Doc) -> ParsecParser [a] -> FieldDescr [a]
forall a. String -> (a -> Doc) -> ParsecParser a -> FieldDescr a
fieldParsec String
name [a] -> Doc
showF' (ParsecParser a -> ParsecParser [a]
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 [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
++ [a]
xs) b
b
     showF' :: [a] -> Doc
showF'    = Separator
separator Separator -> ([a] -> [Doc]) -> [a] -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Doc -> [Doc] -> [Doc]
punctuate Doc
comma ([Doc] -> [Doc]) -> ([a] -> [Doc]) -> [a] -> [Doc]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> Doc) -> [a] -> [Doc]
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 :: String
-> (a -> Doc)
-> ParsecParser a
-> (b -> [a])
-> ([a] -> b -> b)
-> FieldDescr b
commaListFieldParsec = Separator
-> String
-> (a -> Doc)
-> ParsecParser a
-> (b -> [a])
-> ([a] -> b -> b)
-> FieldDescr b
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 :: String
-> (a -> Doc)
-> ParsecParser a
-> (b -> [a])
-> ([a] -> b -> b)
-> FieldDescr b
commaNewLineListFieldParsec = Separator
-> String
-> (a -> Doc)
-> ParsecParser a
-> (b -> [a])
-> ([a] -> b -> b)
-> FieldDescr b
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 :: 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 =
  (b -> [a]) -> ([a] -> b -> b) -> FieldDescr [a] -> FieldDescr b
forall b a.
(b -> a) -> (a -> b -> b) -> FieldDescr a -> FieldDescr b
liftField b -> [a]
get [a] -> b -> b
set' (FieldDescr [a] -> FieldDescr b) -> FieldDescr [a] -> FieldDescr b
forall a b. (a -> b) -> a -> b
$
    String -> ([a] -> Doc) -> ReadP [a] [a] -> FieldDescr [a]
forall a. String -> (a -> Doc) -> ReadP a a -> FieldDescr a
field String
name [a] -> Doc
showF' (ReadP [a] a -> ReadP [a] [a]
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 [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
++ [a]
xs) b
b
    showF' :: [a] -> Doc
showF'    = Separator
fsep Separator -> ([a] -> [Doc]) -> [a] -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> Doc) -> [a] -> [Doc]
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 :: String
-> (a -> Doc)
-> ReadP [a] a
-> (b -> [a])
-> ([a] -> b -> b)
-> FieldDescr b
newLineListField = Separator
-> String
-> (a -> Doc)
-> ReadP [a] a
-> (b -> [a])
-> ([a] -> b -> b)
-> FieldDescr b
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 :: 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 =
  (b -> [a]) -> ([a] -> b -> b) -> FieldDescr [a] -> FieldDescr b
forall b a.
(b -> a) -> (a -> b -> b) -> FieldDescr a -> FieldDescr b
liftField b -> [a]
get [a] -> b -> b
set' (FieldDescr [a] -> FieldDescr b) -> FieldDescr [a] -> FieldDescr b
forall a b. (a -> b) -> a -> b
$
    String -> ([a] -> Doc) -> ReadP [a] [a] -> FieldDescr [a]
forall a. String -> (a -> Doc) -> ReadP a a -> FieldDescr a
field String
name [a] -> Doc
showF' (ReadP [a] a -> ReadP [a] [a]
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 [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
++ [a]
xs) b
b
    showF' :: [a] -> Doc
showF'    = Separator
separator Separator -> ([a] -> [Doc]) -> [a] -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> Doc) -> [a] -> [Doc]
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 :: 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 =
  (b -> [a]) -> ([a] -> b -> b) -> FieldDescr [a] -> FieldDescr b
forall b a.
(b -> a) -> (a -> b -> b) -> FieldDescr a -> FieldDescr b
liftField b -> [a]
get [a] -> b -> b
set' (FieldDescr [a] -> FieldDescr b) -> FieldDescr [a] -> FieldDescr b
forall a b. (a -> b) -> a -> b
$
    String -> ([a] -> Doc) -> ParsecParser [a] -> FieldDescr [a]
forall a. String -> (a -> Doc) -> ParsecParser a -> FieldDescr a
fieldParsec String
name [a] -> Doc
showF' (ParsecParser a -> ParsecParser [a]
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 [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
++ [a]
xs) b
b
    showF' :: [a] -> Doc
showF'    = Separator
separator Separator -> ([a] -> [Doc]) -> [a] -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> Doc) -> [a] -> [Doc]
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 :: String
-> (a -> Doc)
-> ReadP [a] a
-> (b -> [a])
-> ([a] -> b -> b)
-> FieldDescr b
listField = Separator
-> String
-> (a -> Doc)
-> ReadP [a] a
-> (b -> [a])
-> ([a] -> b -> b)
-> FieldDescr b
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 :: String
-> (a -> Doc)
-> ParsecParser a
-> (b -> [a])
-> ([a] -> b -> b)
-> FieldDescr b
listFieldParsec = Separator
-> String
-> (a -> Doc)
-> ParsecParser a
-> (b -> [a])
-> ([a] -> b -> b)
-> FieldDescr b
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 (Int -> Field -> ShowS
[Field] -> ShowS
Field -> String
(Int -> Field -> ShowS)
-> (Field -> String) -> ([Field] -> ShowS) -> Show Field
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Field] -> ShowS
$cshowList :: [Field] -> ShowS
show :: Field -> String
$cshow :: Field -> String
showsPrec :: Int -> Field -> ShowS
$cshowsPrec :: Int -> Field -> ShowS
Show
               ,Field -> Field -> Bool
(Field -> Field -> Bool) -> (Field -> Field -> Bool) -> Eq Field
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 -> Int
lineNo (F Int
n String
_ String
_) = Int
n
lineNo (Section Int
n String
_ String
_ [Field]
_) = Int
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) -> [PWarning] -> [Field] -> ParseResult [Field]
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      -> PError -> ParseResult [Field]
forall a. PError -> ParseResult a
ParseFailed (PError -> ParseResult [Field]) -> PError -> ParseResult [Field]
forall a b. (a -> b) -> a -> b
$ String -> Int -> 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 -> Int
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 = (Field Position -> Field) -> [Field Position] -> [Field]
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) =
    Int -> String -> String -> Field
F (Position -> Int
posToLineNo Position
pos) (ByteString -> String
fromUTF8BS ByteString
name) ([FieldLine Position] -> String
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) =
    Int -> String -> String -> [Field] -> Field
Section (Position -> Int
posToLineNo Position
pos) (ByteString -> String
fromUTF8BS ByteString
name) ([SectionArg Position] -> String
forall ann. [SectionArg ann] -> String
Fields.sectionArgsToString [SectionArg Position]
args) ([Field Position] -> [Field]
legacyFields [Field Position]
fs)

posToLineNo :: Parsec.Position -> LineNo
posToLineNo :: Position -> Int
posToLineNo (Parsec.Position Int
row Int
_) = Int
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 :: ReadP r String
parseHaskellString =
  ReadS String -> ReadP r String
forall a r. ReadS a -> ReadP r a
readS_to_P (ReadS String -> ReadP r String) -> ReadS String -> ReadP r String
forall a b. (a -> b) -> a -> b
$
    ReadPrec String -> Int -> ReadS String
forall a. ReadPrec a -> Int -> ReadS a
Read.readPrec_to_S (do Read.String String
s <- ReadPrec Lexeme
Read.lexP; String -> ReadPrec String
forall (m :: * -> *) a. Monad m => a -> m a
return String
s) Int
0

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

parseSpaceList :: ReadP r a -- ^The parser for the stuff between commas
               -> ReadP r [a]
parseSpaceList :: ReadP r a -> ReadP r [a]
parseSpaceList ReadP r a
p = ReadP r a -> ReadP r () -> ReadP r [a]
forall r a sep. ReadP r a -> ReadP r sep -> ReadP r [a]
sepBy ReadP r a
p ReadP r ()
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 :: ReadP r a -> ReadP r [a]
parseOptCommaList ReadP r a
p = ReadP r a -> ReadP r () -> ReadP r [a]
forall r a sep. ReadP r a -> ReadP r sep -> ReadP r [a]
sepBy ReadP r a
p ReadP r ()
forall r. ReadP r ()
localSep
  where
    -- The separator must not be empty or it introduces ambiguity
    localSep :: ReadP r ()
localSep = (ReadP r ()
forall r. ReadP r ()
skipSpaces ReadP r () -> Parser r Char Char -> Parser r Char Char
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Char -> Parser r Char Char
forall r. Char -> ReadP r Char
char Char
',' Parser r Char Char -> ReadP r () -> ReadP r ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ReadP r ()
forall r. ReadP r ()
skipSpaces)
      ReadP r () -> ReadP r () -> ReadP r ()
forall r a. ReadP r a -> ReadP r a -> ReadP r a
+++ ((Char -> Bool) -> Parser r Char Char
forall r. (Char -> Bool) -> ReadP r Char
satisfy Char -> Bool
isSpace Parser r Char Char -> ReadP r () -> ReadP r ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ReadP r ()
forall r. ReadP r ()
skipSpaces)

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