{-# LANGUAGE Rank2Types #-}
-----------------------------------------------------------------------------
-- This module is meant to be local-only to Distribution...
{-# OPTIONS_HADDOCK hide #-}

-- |
-- 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.
module Distribution.Deprecated.ParseUtils
  ( LineNo
  , PError (..)
  , PWarning (..)
  , locatedErrorMsg
  , syntaxError
  , warning
  , runP
  , runE
  , ParseResult (..)
  , parseFail
  , showPWarning
  , Field (..)
  , lineNo
  , FieldDescr (..)
  , readFields
  , parseHaskellString
  , parseTokenQ
  , parseSpaceList
  , 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, comma, fsep, punctuate, 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.Fields.LexerMonad as Fields
import qualified Distribution.Parsec as Parsec
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
$c== :: PError -> PError -> Bool
== :: PError -> PError -> Bool
$c/= :: PError -> PError -> Bool
/= :: PError -> PError -> Bool
Eq, LineNo -> PError -> ShowS
[PError] -> ShowS
PError -> String
(LineNo -> PError -> ShowS)
-> (PError -> String) -> ([PError] -> ShowS) -> Show PError
forall a.
(LineNo -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: LineNo -> PError -> ShowS
showsPrec :: LineNo -> PError -> ShowS
$cshow :: PError -> String
show :: PError -> String
$cshowList :: [PError] -> ShowS
showList :: [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
$c== :: PWarning -> PWarning -> Bool
== :: PWarning -> PWarning -> Bool
$c/= :: PWarning -> PWarning -> Bool
/= :: PWarning -> PWarning -> Bool
Eq, LineNo -> PWarning -> ShowS
[PWarning] -> ShowS
PWarning -> String
(LineNo -> PWarning -> ShowS)
-> (PWarning -> String) -> ([PWarning] -> ShowS) -> Show PWarning
forall a.
(LineNo -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: LineNo -> PWarning -> ShowS
showsPrec :: LineNo -> PWarning -> ShowS
$cshow :: PWarning -> String
show :: PWarning -> String
$cshowList :: [PWarning] -> ShowS
showList :: [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 LineNo
line String
fname) =
  ShowS
normalise String
fpath
    String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
":"
    String -> ShowS
forall a. [a] -> [a] -> [a]
++ LineNo -> String
forall a. Show a => a -> String
show LineNo
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 (LineNo -> ParseResult a -> ShowS
[ParseResult a] -> ShowS
ParseResult a -> String
(LineNo -> ParseResult a -> ShowS)
-> (ParseResult a -> String)
-> ([ParseResult a] -> ShowS)
-> Show (ParseResult a)
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
$cshowsPrec :: forall a. Show a => LineNo -> ParseResult a -> ShowS
showsPrec :: LineNo -> ParseResult a -> ShowS
$cshow :: forall a. Show a => ParseResult a -> String
show :: ParseResult a -> String
$cshowList :: forall a. Show a => [ParseResult a] -> ShowS
showList :: [ParseResult a] -> ShowS
Show)

instance Functor ParseResult where
  fmap :: forall a b. (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 :: forall a. a -> ParseResult a
pure = [PWarning] -> a -> ParseResult a
forall a. [PWarning] -> a -> ParseResult a
ParseOk []
  <*> :: forall a b. 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 :: forall a. a -> ParseResult a
return = a -> ParseResult a
forall a. a -> ParseResult a
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
_ = 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'

instance Foldable ParseResult where
  foldMap :: forall m a. Monoid m => (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 :: forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> ParseResult a -> f (ParseResult b)
traverse a -> f b
_ (ParseFailed PError
err) = ParseResult b -> f (ParseResult b)
forall a. a -> f a
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 :: forall a. String -> ParseResult a
fail = String -> ParseResult a
forall a. String -> ParseResult a
parseResultFail

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

parseFail :: PError -> ParseResult a
parseFail :: forall a. PError -> ParseResult a
parseFail = PError -> ParseResult a
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] -> [PWarning] -> a -> ParseResult 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, (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 (LineNo -> String -> String -> [PWarning]
utf8Warnings LineNo
line String
fieldname String
s) a
a
      [] -> PError -> ParseResult a
forall a. PError -> ParseResult a
ParseFailed (String -> LineNo -> PError
NoParse String
fieldname LineNo
line)
      [a]
_ -> PError -> ParseResult a
forall a. PError -> ParseResult a
ParseFailed (String -> LineNo -> PError
AmbiguousParse String
fieldname LineNo
line)
    [a]
_ -> PError -> ParseResult a
forall a. PError -> ParseResult a
ParseFailed (String -> LineNo -> PError
AmbiguousParse String
fieldname LineNo
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 :: forall a. LineNo -> String -> ReadE a -> String -> ParseResult a
runE LineNo
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 (LineNo -> String -> String -> [PWarning]
utf8Warnings LineNo
line String
fieldname String
s) a
a
    Left String
e ->
      LineNo -> String -> ParseResult a
forall a. LineNo -> String -> ParseResult a
syntaxError LineNo
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 :: LineNo -> String -> String -> [PWarning]
utf8Warnings LineNo
line String
fieldname String
s =
  LineNo -> [PWarning] -> [PWarning]
forall a. LineNo -> [a] -> [a]
take
    LineNo
1
    [ LineNo -> String -> PWarning
UTFWarning LineNo
n String
fieldname
    | (LineNo
n, String
l) <- [LineNo] -> [String] -> [(LineNo, String)]
forall a b. [a] -> [b] -> [(a, b)]
zip [LineNo
line ..] (String -> [String]
lines String
s)
    , Char
'\xfffd' Char -> String -> Bool
forall a. Eq a => a -> [a] -> Bool
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) =
  ( LineNo -> Maybe LineNo
forall a. a -> Maybe a
Just LineNo
n
  , String
"Ambiguous parse in field '" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
f String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"'."
  )
locatedErrorMsg (NoParse String
f LineNo
n) =
  ( LineNo -> Maybe LineNo
forall a. a -> Maybe a
Just LineNo
n
  , String
"Parse of field '" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
f String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"' failed."
  )
locatedErrorMsg (TabsError LineNo
n) = (LineNo -> Maybe LineNo
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 = PError -> ParseResult a
forall a. PError -> ParseResult a
ParseFailed (PError -> ParseResult a) -> PError -> ParseResult a
forall a b. (a -> b) -> a -> b
$ String -> Maybe LineNo -> PError
FromString String
s (LineNo -> Maybe LineNo
forall a. a -> Maybe a
Just LineNo
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
  { 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 =
  String
-> (a -> Doc)
-> (LineNo -> String -> a -> ParseResult a)
-> FieldDescr a
forall a.
String
-> (a -> Doc)
-> (LineNo -> String -> a -> ParseResult a)
-> FieldDescr a
FieldDescr String
name a -> Doc
showF (\LineNo
line String
val a
_st -> LineNo -> String -> ReadP a a -> String -> ParseResult a
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 =
  String
-> (a -> Doc)
-> (LineNo -> String -> a -> ParseResult a)
-> FieldDescr a
forall a.
String
-> (a -> Doc)
-> (LineNo -> String -> a -> ParseResult a)
-> FieldDescr a
FieldDescr String
name a -> Doc
showF ((LineNo -> String -> a -> ParseResult a) -> FieldDescr a)
-> (LineNo -> String -> a -> ParseResult a) -> FieldDescr a
forall a b. (a -> b) -> a -> b
$ \LineNo
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 LineNo -> PError
FromString String
err (LineNo -> Maybe LineNo
forall a. a -> Maybe a
Just LineNo
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 :: 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) =
  String
-> (b -> Doc)
-> (LineNo -> String -> b -> ParseResult b)
-> FieldDescr b
forall a.
String
-> (a -> Doc)
-> (LineNo -> 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)
    ( \LineNo
line String
str b
b -> do
        a
a <- LineNo -> String -> a -> ParseResult a
parseF LineNo
line String
str (b -> a
get b
b)
        b -> ParseResult b
forall a. a -> ParseResult a
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 =
  (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 :: 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 =
  (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 :: 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 =
  (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 :: forall a b.
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 :: forall a b.
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 :: 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 =
  (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 :: forall a b.
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 :: 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 =
  (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 :: 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 =
  (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 :: forall a b.
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 :: forall a b.
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
  = -- | A regular @<property>: <value>@ field
    F LineNo String String
  | -- | A section with a name and possible parameter.  The syntactic
    -- structure is:
    --
    -- @
    --   <sectionname> <arg> {
    --     <field>*
    --   }
    -- @
    Section LineNo String String [Field]
  deriving
    ( LineNo -> Field -> ShowS
[Field] -> ShowS
Field -> String
(LineNo -> Field -> ShowS)
-> (Field -> String) -> ([Field] -> ShowS) -> Show Field
forall a.
(LineNo -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: LineNo -> Field -> ShowS
showsPrec :: LineNo -> Field -> ShowS
$cshow :: Field -> String
show :: Field -> String
$cshowList :: [Field] -> ShowS
showList :: [Field] -> ShowS
Show
    , Field -> Field -> Bool
(Field -> Field -> Bool) -> (Field -> Field -> Bool) -> Eq Field
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Field -> Field -> Bool
== :: Field -> Field -> Bool
$c/= :: Field -> Field -> Bool
/= :: 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) ->
    [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 -> 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 = (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) =
  LineNo -> String -> String -> Field
F (Position -> LineNo
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) =
  LineNo -> String -> String -> [Field] -> Field
Section (Position -> LineNo
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 -> 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 =
  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 -> LineNo -> ReadS String
forall a. ReadPrec a -> LineNo -> ReadS a
Read.readPrec_to_S (do Read.String String
s <- ReadPrec Lexeme
Read.lexP; String -> ReadPrec String
forall a. a -> ReadPrec a
forall (m :: * -> *) a. Monad m => a -> m a
return String
s) LineNo
0

parseTokenQ :: ReadP r String
parseTokenQ :: forall r. 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 :: forall r a. 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 :: forall r a. 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 a b. Parser r Char a -> Parser r Char b -> Parser r Char b
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 a b. Parser r Char a -> Parser r Char b -> Parser r Char b
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 a b. Parser r Char a -> Parser r Char b -> Parser r Char b
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 :: forall a. 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
    ]