{-# LANGUAGE CPP                   #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings     #-}
{-# LANGUAGE PatternGuards         #-}
-----------------------------------------------------------------------------
-- |
-- Module      :  Distribution.Fields.Parser
-- License     :  BSD3
--
-- Maintainer  :  cabal-devel@haskell.org
-- Portability :  portable
module Distribution.Fields.Parser (
    -- * Types
    Field(..),
    Name(..),
    FieldLine(..),
    SectionArg(..),
    -- * Grammar and parsing
    -- $grammar
    readFields,
    readFields',
#ifdef CABAL_PARSEC_DEBUG
    -- * Internal
    parseFile,
    parseStr,
    parseBS,
#endif
    ) where

import qualified Data.ByteString.Char8          as B8
import           Data.Functor.Identity
import           Distribution.Compat.Prelude
import           Distribution.Fields.Field
import           Distribution.Fields.Lexer
import           Distribution.Fields.LexerMonad
                 (LexResult (..), LexState (..), LexWarning (..), unLex)
import           Distribution.Parsec.Position   (Position (..))
import           Prelude ()
import           Text.Parsec.Combinator         hiding (eof, notFollowedBy)
import           Text.Parsec.Error
import           Text.Parsec.Pos
import           Text.Parsec.Prim               hiding (many, (<|>))

#ifdef CABAL_PARSEC_DEBUG
import qualified Data.Text                as T
import qualified Data.Text.Encoding       as T
import qualified Data.Text.Encoding.Error as T
#endif

-- $setup
-- >>> import Data.Either (isLeft)

-- | The 'LexState'' (with a prime) is an instance of parsec's 'Stream'
-- wrapped around lexer's 'LexState' (without a prime)
data LexState' = LexState' !LexState (LToken, LexState')

mkLexState' :: LexState -> LexState'
mkLexState' :: LexState -> LexState'
mkLexState' LexState
st = LexState -> (LToken, LexState') -> LexState'
LexState' LexState
st
                   (case Lex LToken -> LexState -> LexResult LToken
forall a. Lex a -> LexState -> LexResult a
unLex Lex LToken
lexToken LexState
st of LexResult LexState
st' LToken
tok -> (LToken
tok, LexState -> LexState'
mkLexState' LexState
st'))

type Parser a = ParsecT LexState' () Identity a

instance Stream LexState' Identity LToken where
  uncons :: LexState' -> Identity (Maybe (LToken, LexState'))
uncons (LexState' LexState
_ (LToken
tok, LexState'
st')) =
    case LToken
tok of
      L Position
_ Token
EOF -> Maybe (LToken, LexState') -> Identity (Maybe (LToken, LexState'))
forall a. a -> Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (LToken, LexState')
forall a. Maybe a
Nothing
      LToken
_       -> Maybe (LToken, LexState') -> Identity (Maybe (LToken, LexState'))
forall a. a -> Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return ((LToken, LexState') -> Maybe (LToken, LexState')
forall a. a -> Maybe a
Just (LToken
tok, LexState'
st'))

-- | Get lexer warnings accumulated so far
getLexerWarnings :: Parser [LexWarning]
getLexerWarnings :: Parser [LexWarning]
getLexerWarnings = do
  LexState' (LexState { warnings :: LexState -> [LexWarning]
warnings = [LexWarning]
ws }) (LToken, LexState')
_ <- ParsecT LexState' () Identity LexState'
forall (m :: * -> *) s u. Monad m => ParsecT s u m s
getInput
  [LexWarning] -> Parser [LexWarning]
forall a. a -> ParsecT LexState' () Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return [LexWarning]
ws

-- | Set Alex code i.e. the mode "state" lexer is in.
setLexerMode :: Int -> Parser ()
setLexerMode :: Int -> Parser ()
setLexerMode Int
code = do
  LexState' LexState
ls (LToken, LexState')
_ <- ParsecT LexState' () Identity LexState'
forall (m :: * -> *) s u. Monad m => ParsecT s u m s
getInput
  LexState' -> Parser ()
forall (m :: * -> *) s u. Monad m => s -> ParsecT s u m ()
setInput (LexState' -> Parser ()) -> LexState' -> Parser ()
forall a b. (a -> b) -> a -> b
$! LexState -> LexState'
mkLexState' LexState
ls { curCode = code }

getToken :: (Token -> Maybe a) -> Parser a
getToken :: forall a. (Token -> Maybe a) -> Parser a
getToken Token -> Maybe a
getTok = (LToken -> Maybe a) -> Parser a
forall a. (LToken -> Maybe a) -> Parser a
getTokenWithPos (\(L Position
_ Token
t) -> Token -> Maybe a
getTok Token
t)

getTokenWithPos :: (LToken -> Maybe a) -> Parser a
getTokenWithPos :: forall a. (LToken -> Maybe a) -> Parser a
getTokenWithPos LToken -> Maybe a
getTok = (LToken -> [Char])
-> (SourcePos -> LToken -> LexState' -> SourcePos)
-> (LToken -> Maybe a)
-> ParsecT LexState' () Identity a
forall s (m :: * -> *) t a u.
Stream s m t =>
(t -> [Char])
-> (SourcePos -> t -> s -> SourcePos)
-> (t -> Maybe a)
-> ParsecT s u m a
tokenPrim (\(L Position
_ Token
t) -> Token -> [Char]
describeToken Token
t) SourcePos -> LToken -> LexState' -> SourcePos
updatePos LToken -> Maybe a
getTok
  where
    updatePos :: SourcePos -> LToken -> LexState' -> SourcePos
    updatePos :: SourcePos -> LToken -> LexState' -> SourcePos
updatePos SourcePos
pos (L (Position Int
col Int
line) Token
_) LexState'
_ = [Char] -> Int -> Int -> SourcePos
newPos (SourcePos -> [Char]
sourceName SourcePos
pos) Int
col Int
line

describeToken :: Token -> String
describeToken :: Token -> [Char]
describeToken Token
t = case Token
t of
  TokSym   ByteString
s      -> [Char]
"symbol "   [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ ByteString -> [Char]
forall a. Show a => a -> [Char]
show ByteString
s
  TokStr   ByteString
s      -> [Char]
"string "   [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ ByteString -> [Char]
forall a. Show a => a -> [Char]
show ByteString
s
  TokOther ByteString
s      -> [Char]
"operator " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ ByteString -> [Char]
forall a. Show a => a -> [Char]
show ByteString
s
  Indent Int
_        -> [Char]
"new line"
  TokFieldLine ByteString
_  -> [Char]
"field content"
  Token
Colon           -> [Char]
"\":\""
  Token
OpenBrace       -> [Char]
"\"{\""
  Token
CloseBrace      -> [Char]
"\"}\""
--  SemiColon       -> "\";\""
  Token
EOF             -> [Char]
"end of file"
  LexicalError ByteString
is -> [Char]
"character in input " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Char -> [Char]
forall a. Show a => a -> [Char]
show (ByteString -> Char
B8.head ByteString
is)

tokSym :: Parser (Name Position)
tokSym', tokStr, tokOther :: Parser (SectionArg Position)
tokIndent :: Parser Int
tokColon, tokOpenBrace, tokCloseBrace :: Parser ()
tokFieldLine :: Parser (FieldLine Position)

tokSym :: Parser (Name Position)
tokSym        = (LToken -> Maybe (Name Position)) -> Parser (Name Position)
forall a. (LToken -> Maybe a) -> Parser a
getTokenWithPos ((LToken -> Maybe (Name Position)) -> Parser (Name Position))
-> (LToken -> Maybe (Name Position)) -> Parser (Name Position)
forall a b. (a -> b) -> a -> b
$ \LToken
t -> case LToken
t of L Position
pos (TokSym   ByteString
x) -> Name Position -> Maybe (Name Position)
forall a. a -> Maybe a
Just (Position -> ByteString -> Name Position
forall ann. ann -> ByteString -> Name ann
mkName Position
pos ByteString
x);  LToken
_ -> Maybe (Name Position)
forall a. Maybe a
Nothing
tokSym' :: Parser (SectionArg Position)
tokSym'       = (LToken -> Maybe (SectionArg Position))
-> Parser (SectionArg Position)
forall a. (LToken -> Maybe a) -> Parser a
getTokenWithPos ((LToken -> Maybe (SectionArg Position))
 -> Parser (SectionArg Position))
-> (LToken -> Maybe (SectionArg Position))
-> Parser (SectionArg Position)
forall a b. (a -> b) -> a -> b
$ \LToken
t -> case LToken
t of L Position
pos (TokSym   ByteString
x) -> SectionArg Position -> Maybe (SectionArg Position)
forall a. a -> Maybe a
Just (Position -> ByteString -> SectionArg Position
forall ann. ann -> ByteString -> SectionArg ann
SecArgName Position
pos ByteString
x);  LToken
_ -> Maybe (SectionArg Position)
forall a. Maybe a
Nothing
tokStr :: Parser (SectionArg Position)
tokStr        = (LToken -> Maybe (SectionArg Position))
-> Parser (SectionArg Position)
forall a. (LToken -> Maybe a) -> Parser a
getTokenWithPos ((LToken -> Maybe (SectionArg Position))
 -> Parser (SectionArg Position))
-> (LToken -> Maybe (SectionArg Position))
-> Parser (SectionArg Position)
forall a b. (a -> b) -> a -> b
$ \LToken
t -> case LToken
t of L Position
pos (TokStr   ByteString
x) -> SectionArg Position -> Maybe (SectionArg Position)
forall a. a -> Maybe a
Just (Position -> ByteString -> SectionArg Position
forall ann. ann -> ByteString -> SectionArg ann
SecArgStr Position
pos ByteString
x);  LToken
_ -> Maybe (SectionArg Position)
forall a. Maybe a
Nothing
tokOther :: Parser (SectionArg Position)
tokOther      = (LToken -> Maybe (SectionArg Position))
-> Parser (SectionArg Position)
forall a. (LToken -> Maybe a) -> Parser a
getTokenWithPos ((LToken -> Maybe (SectionArg Position))
 -> Parser (SectionArg Position))
-> (LToken -> Maybe (SectionArg Position))
-> Parser (SectionArg Position)
forall a b. (a -> b) -> a -> b
$ \LToken
t -> case LToken
t of L Position
pos (TokOther ByteString
x) -> SectionArg Position -> Maybe (SectionArg Position)
forall a. a -> Maybe a
Just (Position -> ByteString -> SectionArg Position
forall ann. ann -> ByteString -> SectionArg ann
SecArgOther Position
pos ByteString
x);  LToken
_ -> Maybe (SectionArg Position)
forall a. Maybe a
Nothing
tokIndent :: Parser Int
tokIndent     = (Token -> Maybe Int) -> Parser Int
forall a. (Token -> Maybe a) -> Parser a
getToken ((Token -> Maybe Int) -> Parser Int)
-> (Token -> Maybe Int) -> Parser Int
forall a b. (a -> b) -> a -> b
$ \Token
t -> case Token
t of Indent   Int
x -> Int -> Maybe Int
forall a. a -> Maybe a
Just Int
x;  Token
_ -> Maybe Int
forall a. Maybe a
Nothing
tokColon :: Parser ()
tokColon      = (Token -> Maybe ()) -> Parser ()
forall a. (Token -> Maybe a) -> Parser a
getToken ((Token -> Maybe ()) -> Parser ())
-> (Token -> Maybe ()) -> Parser ()
forall a b. (a -> b) -> a -> b
$ \Token
t -> case Token
t of Token
Colon      -> () -> Maybe ()
forall a. a -> Maybe a
Just (); Token
_ -> Maybe ()
forall a. Maybe a
Nothing
tokOpenBrace :: Parser ()
tokOpenBrace  = (Token -> Maybe ()) -> Parser ()
forall a. (Token -> Maybe a) -> Parser a
getToken ((Token -> Maybe ()) -> Parser ())
-> (Token -> Maybe ()) -> Parser ()
forall a b. (a -> b) -> a -> b
$ \Token
t -> case Token
t of Token
OpenBrace  -> () -> Maybe ()
forall a. a -> Maybe a
Just (); Token
_ -> Maybe ()
forall a. Maybe a
Nothing
tokCloseBrace :: Parser ()
tokCloseBrace = (Token -> Maybe ()) -> Parser ()
forall a. (Token -> Maybe a) -> Parser a
getToken ((Token -> Maybe ()) -> Parser ())
-> (Token -> Maybe ()) -> Parser ()
forall a b. (a -> b) -> a -> b
$ \Token
t -> case Token
t of Token
CloseBrace -> () -> Maybe ()
forall a. a -> Maybe a
Just (); Token
_ -> Maybe ()
forall a. Maybe a
Nothing
tokFieldLine :: Parser (FieldLine Position)
tokFieldLine  = (LToken -> Maybe (FieldLine Position))
-> Parser (FieldLine Position)
forall a. (LToken -> Maybe a) -> Parser a
getTokenWithPos ((LToken -> Maybe (FieldLine Position))
 -> Parser (FieldLine Position))
-> (LToken -> Maybe (FieldLine Position))
-> Parser (FieldLine Position)
forall a b. (a -> b) -> a -> b
$ \LToken
t -> case LToken
t of L Position
pos (TokFieldLine ByteString
s) -> FieldLine Position -> Maybe (FieldLine Position)
forall a. a -> Maybe a
Just (Position -> ByteString -> FieldLine Position
forall ann. ann -> ByteString -> FieldLine ann
FieldLine Position
pos ByteString
s); LToken
_ -> Maybe (FieldLine Position)
forall a. Maybe a
Nothing

colon, openBrace, closeBrace :: Parser ()

sectionArg :: Parser (SectionArg Position)
sectionArg :: Parser (SectionArg Position)
sectionArg   = Parser (SectionArg Position)
tokSym' Parser (SectionArg Position)
-> Parser (SectionArg Position) -> Parser (SectionArg Position)
forall a.
ParsecT LexState' () Identity a
-> ParsecT LexState' () Identity a
-> ParsecT LexState' () Identity a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser (SectionArg Position)
tokStr Parser (SectionArg Position)
-> Parser (SectionArg Position) -> Parser (SectionArg Position)
forall a.
ParsecT LexState' () Identity a
-> ParsecT LexState' () Identity a
-> ParsecT LexState' () Identity a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser (SectionArg Position)
tokOther Parser (SectionArg Position)
-> [Char] -> Parser (SectionArg Position)
forall s u (m :: * -> *) a.
ParsecT s u m a -> [Char] -> ParsecT s u m a
<?> [Char]
"section parameter"

fieldSecName :: Parser (Name Position)
fieldSecName :: Parser (Name Position)
fieldSecName = Parser (Name Position)
tokSym              Parser (Name Position) -> [Char] -> Parser (Name Position)
forall s u (m :: * -> *) a.
ParsecT s u m a -> [Char] -> ParsecT s u m a
<?> [Char]
"field or section name"

colon :: Parser ()
colon        = Parser ()
tokColon      Parser () -> [Char] -> Parser ()
forall s u (m :: * -> *) a.
ParsecT s u m a -> [Char] -> ParsecT s u m a
<?> [Char]
"\":\""
openBrace :: Parser ()
openBrace    = Parser ()
tokOpenBrace  Parser () -> [Char] -> Parser ()
forall s u (m :: * -> *) a.
ParsecT s u m a -> [Char] -> ParsecT s u m a
<?> [Char]
"\"{\""
closeBrace :: Parser ()
closeBrace   = Parser ()
tokCloseBrace Parser () -> [Char] -> Parser ()
forall s u (m :: * -> *) a.
ParsecT s u m a -> [Char] -> ParsecT s u m a
<?> [Char]
"\"}\""

fieldContent :: Parser (FieldLine Position)
fieldContent :: Parser (FieldLine Position)
fieldContent = Parser (FieldLine Position)
tokFieldLine Parser (FieldLine Position)
-> [Char] -> Parser (FieldLine Position)
forall s u (m :: * -> *) a.
ParsecT s u m a -> [Char] -> ParsecT s u m a
<?> [Char]
"field contents"

newtype IndentLevel = IndentLevel Int

zeroIndentLevel :: IndentLevel
zeroIndentLevel :: IndentLevel
zeroIndentLevel = Int -> IndentLevel
IndentLevel Int
0

incIndentLevel :: IndentLevel -> IndentLevel
incIndentLevel :: IndentLevel -> IndentLevel
incIndentLevel (IndentLevel Int
i) = Int -> IndentLevel
IndentLevel (Int -> Int
forall a. Enum a => a -> a
succ Int
i)

indentOfAtLeast :: IndentLevel -> Parser IndentLevel
indentOfAtLeast :: IndentLevel -> Parser IndentLevel
indentOfAtLeast (IndentLevel Int
i) = Parser IndentLevel -> Parser IndentLevel
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m a
try (Parser IndentLevel -> Parser IndentLevel)
-> Parser IndentLevel -> Parser IndentLevel
forall a b. (a -> b) -> a -> b
$ do
  Int
j <- Parser Int
tokIndent
  Bool -> Parser ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Int
j Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
i) Parser () -> [Char] -> Parser ()
forall s u (m :: * -> *) a.
ParsecT s u m a -> [Char] -> ParsecT s u m a
<?> [Char]
"indentation of at least " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Show a => a -> [Char]
show Int
i
  IndentLevel -> Parser IndentLevel
forall a. a -> ParsecT LexState' () Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> IndentLevel
IndentLevel Int
j)


newtype LexerMode = LexerMode Int

inLexerMode :: LexerMode -> Parser p -> Parser p
inLexerMode :: forall p. LexerMode -> Parser p -> Parser p
inLexerMode (LexerMode Int
mode) Parser p
p =
  do Int -> Parser ()
setLexerMode Int
mode; p
x <- Parser p
p; Int -> Parser ()
setLexerMode Int
in_section; p -> Parser p
forall a. a -> ParsecT LexState' () Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return p
x


-----------------------
-- Cabal file grammar
--

-- $grammar
--
-- @
-- CabalStyleFile ::= SecElems
--
-- SecElems       ::= SecElem* '\\n'?
-- SecElem        ::= '\\n' SecElemLayout | SecElemBraces
-- SecElemLayout  ::= FieldLayout | FieldBraces | SectionLayout | SectionBraces
-- SecElemBraces  ::= FieldInline | FieldBraces |                 SectionBraces
-- FieldLayout    ::= name ':' line? ('\\n' line)*
-- FieldBraces    ::= name ':' '\\n'? '{' content '}'
-- FieldInline    ::= name ':' content
-- SectionLayout  ::= name arg* SecElems
-- SectionBraces  ::= name arg* '\\n'? '{' SecElems '}'
-- @
--
-- and the same thing but left factored...
--
-- @
-- SecElems              ::= SecElem*
-- SecElem               ::= '\\n' name SecElemLayout
--                         |      name SecElemBraces
-- SecElemLayout         ::= ':'   FieldLayoutOrBraces
--                         | arg*  SectionLayoutOrBraces
-- FieldLayoutOrBraces   ::= '\\n'? '{' content '}'
--                         | line? ('\\n' line)*
-- SectionLayoutOrBraces ::= '\\n'? '{' SecElems '\\n'? '}'
--                         | SecElems
-- SecElemBraces         ::= ':' FieldInlineOrBraces
--                         | arg* '\\n'? '{' SecElems '\\n'? '}'
-- FieldInlineOrBraces   ::= '\\n'? '{' content '}'
--                         | content
-- @
--
-- Note how we have several productions with the sequence:
--
-- > '\\n'? '{'
--
-- That is, an optional newline (and indent) followed by a @{@ token.
-- In the @SectionLayoutOrBraces@ case you can see that this makes it
-- not fully left factored (because @SecElems@ can start with a @\\n@).
-- Fully left factoring here would be ugly, and though we could use a
-- lookahead of two tokens to resolve the alternatives, we can't
-- conveniently use Parsec's 'try' here to get a lookahead of only two.
-- So instead we deal with this case in the lexer by making a line
-- where the first non-space is @{@ lex as just the @{@ token, without
-- the usual indent token. Then in the parser we can resolve everything
-- with just one token of lookahead and so without using 'try'.

-- Top level of a file using cabal syntax
--
cabalStyleFile :: Parser [Field Position]
cabalStyleFile :: Parser [Field Position]
cabalStyleFile = do [Field Position]
es <- IndentLevel -> Parser [Field Position]
elements IndentLevel
zeroIndentLevel
                    Parser ()
eof
                    [Field Position] -> Parser [Field Position]
forall a. a -> ParsecT LexState' () Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return [Field Position]
es

-- Elements that live at the top level or inside a section, i.e. fields
-- and sections content
--
-- elements ::= element*
elements :: IndentLevel -> Parser [Field Position]
elements :: IndentLevel -> Parser [Field Position]
elements IndentLevel
ilevel = ParsecT LexState' () Identity (Field Position)
-> Parser [Field Position]
forall a.
ParsecT LexState' () Identity a
-> ParsecT LexState' () Identity [a]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
many (IndentLevel -> ParsecT LexState' () Identity (Field Position)
element IndentLevel
ilevel)

-- An individual element, ie a field or a section. These can either use
-- layout style or braces style. For layout style then it must start on
-- a line on its own (so that we know its indentation level).
--
-- element ::= '\\n' name elementInLayoutContext
--           |      name elementInNonLayoutContext
element :: IndentLevel -> Parser (Field Position)
element :: IndentLevel -> ParsecT LexState' () Identity (Field Position)
element IndentLevel
ilevel =
      (do IndentLevel
ilevel' <- IndentLevel -> Parser IndentLevel
indentOfAtLeast IndentLevel
ilevel
          Name Position
name    <- Parser (Name Position)
fieldSecName
          IndentLevel
-> Name Position -> ParsecT LexState' () Identity (Field Position)
elementInLayoutContext (IndentLevel -> IndentLevel
incIndentLevel IndentLevel
ilevel') Name Position
name)
  ParsecT LexState' () Identity (Field Position)
-> ParsecT LexState' () Identity (Field Position)
-> ParsecT LexState' () Identity (Field Position)
forall a.
ParsecT LexState' () Identity a
-> ParsecT LexState' () Identity a
-> ParsecT LexState' () Identity a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (do Name Position
name    <- Parser (Name Position)
fieldSecName
          Name Position -> ParsecT LexState' () Identity (Field Position)
elementInNonLayoutContext Name Position
name)

-- An element (field or section) that is valid in a layout context.
-- In a layout context we can have fields and sections that themselves
-- either use layout style or that use braces style.
--
-- elementInLayoutContext ::= ':'  fieldLayoutOrBraces
--                          | arg* sectionLayoutOrBraces
elementInLayoutContext :: IndentLevel -> Name Position -> Parser (Field Position)
elementInLayoutContext :: IndentLevel
-> Name Position -> ParsecT LexState' () Identity (Field Position)
elementInLayoutContext IndentLevel
ilevel Name Position
name =
      (do Parser ()
colon; IndentLevel
-> Name Position -> ParsecT LexState' () Identity (Field Position)
fieldLayoutOrBraces IndentLevel
ilevel Name Position
name)
  ParsecT LexState' () Identity (Field Position)
-> ParsecT LexState' () Identity (Field Position)
-> ParsecT LexState' () Identity (Field Position)
forall a.
ParsecT LexState' () Identity a
-> ParsecT LexState' () Identity a
-> ParsecT LexState' () Identity a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (do [SectionArg Position]
args  <- Parser (SectionArg Position)
-> ParsecT LexState' () Identity [SectionArg Position]
forall a.
ParsecT LexState' () Identity a
-> ParsecT LexState' () Identity [a]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
many Parser (SectionArg Position)
sectionArg
          [Field Position]
elems <- IndentLevel -> Parser [Field Position]
sectionLayoutOrBraces IndentLevel
ilevel
          Field Position -> ParsecT LexState' () Identity (Field Position)
forall a. a -> ParsecT LexState' () Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (Name Position
-> [SectionArg Position] -> [Field Position] -> Field Position
forall ann.
Name ann -> [SectionArg ann] -> [Field ann] -> Field ann
Section Name Position
name [SectionArg Position]
args [Field Position]
elems))

-- An element (field or section) that is valid in a non-layout context.
-- In a non-layout context we can have only have fields and sections that
-- themselves use braces style, or inline style fields.
--
-- elementInNonLayoutContext ::= ':' FieldInlineOrBraces
--                             | arg* '\\n'? '{' elements '\\n'? '}'
elementInNonLayoutContext :: Name Position -> Parser (Field Position)
elementInNonLayoutContext :: Name Position -> ParsecT LexState' () Identity (Field Position)
elementInNonLayoutContext Name Position
name =
      (do Parser ()
colon; Name Position -> ParsecT LexState' () Identity (Field Position)
fieldInlineOrBraces Name Position
name)
  ParsecT LexState' () Identity (Field Position)
-> ParsecT LexState' () Identity (Field Position)
-> ParsecT LexState' () Identity (Field Position)
forall a.
ParsecT LexState' () Identity a
-> ParsecT LexState' () Identity a
-> ParsecT LexState' () Identity a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (do [SectionArg Position]
args <- Parser (SectionArg Position)
-> ParsecT LexState' () Identity [SectionArg Position]
forall a.
ParsecT LexState' () Identity a
-> ParsecT LexState' () Identity [a]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
many Parser (SectionArg Position)
sectionArg
          Parser ()
openBrace
          [Field Position]
elems <- IndentLevel -> Parser [Field Position]
elements IndentLevel
zeroIndentLevel
          Parser Int -> Parser ()
forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m ()
optional Parser Int
tokIndent
          Parser ()
closeBrace
          Field Position -> ParsecT LexState' () Identity (Field Position)
forall a. a -> ParsecT LexState' () Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (Name Position
-> [SectionArg Position] -> [Field Position] -> Field Position
forall ann.
Name ann -> [SectionArg ann] -> [Field ann] -> Field ann
Section Name Position
name [SectionArg Position]
args [Field Position]
elems))

-- The body of a field, using either layout style or braces style.
--
-- fieldLayoutOrBraces   ::= '\\n'? '{' content '}'
--                         | line? ('\\n' line)*
fieldLayoutOrBraces :: IndentLevel -> Name Position -> Parser (Field Position)
fieldLayoutOrBraces :: IndentLevel
-> Name Position -> ParsecT LexState' () Identity (Field Position)
fieldLayoutOrBraces IndentLevel
ilevel Name Position
name = ParsecT LexState' () Identity (Field Position)
braces ParsecT LexState' () Identity (Field Position)
-> ParsecT LexState' () Identity (Field Position)
-> ParsecT LexState' () Identity (Field Position)
forall a.
ParsecT LexState' () Identity a
-> ParsecT LexState' () Identity a
-> ParsecT LexState' () Identity a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ParsecT LexState' () Identity (Field Position)
fieldLayout
  where
    braces :: ParsecT LexState' () Identity (Field Position)
braces = do
          Parser ()
openBrace
          [FieldLine Position]
ls <- LexerMode
-> Parser [FieldLine Position] -> Parser [FieldLine Position]
forall p. LexerMode -> Parser p -> Parser p
inLexerMode (Int -> LexerMode
LexerMode Int
in_field_braces) (Parser (FieldLine Position) -> Parser [FieldLine Position]
forall a.
ParsecT LexState' () Identity a
-> ParsecT LexState' () Identity [a]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
many Parser (FieldLine Position)
fieldContent)
          Parser ()
closeBrace
          Field Position -> ParsecT LexState' () Identity (Field Position)
forall a. a -> ParsecT LexState' () Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (Name Position -> [FieldLine Position] -> Field Position
forall ann. Name ann -> [FieldLine ann] -> Field ann
Field Name Position
name [FieldLine Position]
ls)
    fieldLayout :: ParsecT LexState' () Identity (Field Position)
fieldLayout = LexerMode
-> ParsecT LexState' () Identity (Field Position)
-> ParsecT LexState' () Identity (Field Position)
forall p. LexerMode -> Parser p -> Parser p
inLexerMode (Int -> LexerMode
LexerMode Int
in_field_layout) (ParsecT LexState' () Identity (Field Position)
 -> ParsecT LexState' () Identity (Field Position))
-> ParsecT LexState' () Identity (Field Position)
-> ParsecT LexState' () Identity (Field Position)
forall a b. (a -> b) -> a -> b
$ do
          Maybe (FieldLine Position)
l  <- Parser (FieldLine Position)
-> ParsecT LexState' () Identity (Maybe (FieldLine Position))
forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m (Maybe a)
optionMaybe Parser (FieldLine Position)
fieldContent
          [FieldLine Position]
ls <- Parser (FieldLine Position) -> Parser [FieldLine Position]
forall a.
ParsecT LexState' () Identity a
-> ParsecT LexState' () Identity [a]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
many (do IndentLevel
_ <- IndentLevel -> Parser IndentLevel
indentOfAtLeast IndentLevel
ilevel; Parser (FieldLine Position)
fieldContent)
          Field Position -> ParsecT LexState' () Identity (Field Position)
forall a. a -> ParsecT LexState' () Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (Field Position -> ParsecT LexState' () Identity (Field Position))
-> Field Position -> ParsecT LexState' () Identity (Field Position)
forall a b. (a -> b) -> a -> b
$ case Maybe (FieldLine Position)
l of
              Maybe (FieldLine Position)
Nothing -> Name Position -> [FieldLine Position] -> Field Position
forall ann. Name ann -> [FieldLine ann] -> Field ann
Field Name Position
name [FieldLine Position]
ls
              Just FieldLine Position
l' -> Name Position -> [FieldLine Position] -> Field Position
forall ann. Name ann -> [FieldLine ann] -> Field ann
Field Name Position
name (FieldLine Position
l' FieldLine Position -> [FieldLine Position] -> [FieldLine Position]
forall a. a -> [a] -> [a]
: [FieldLine Position]
ls)

-- The body of a section, using either layout style or braces style.
--
-- sectionLayoutOrBraces ::= '\\n'? '{' elements \\n? '}'
--                         | elements
sectionLayoutOrBraces :: IndentLevel -> Parser [Field Position]
sectionLayoutOrBraces :: IndentLevel -> Parser [Field Position]
sectionLayoutOrBraces IndentLevel
ilevel =
      (do Parser ()
openBrace
          [Field Position]
elems <- IndentLevel -> Parser [Field Position]
elements IndentLevel
zeroIndentLevel
          Parser Int -> Parser ()
forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m ()
optional Parser Int
tokIndent
          Parser ()
closeBrace
          [Field Position] -> Parser [Field Position]
forall a. a -> ParsecT LexState' () Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return [Field Position]
elems)
  Parser [Field Position]
-> Parser [Field Position] -> Parser [Field Position]
forall a.
ParsecT LexState' () Identity a
-> ParsecT LexState' () Identity a
-> ParsecT LexState' () Identity a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (IndentLevel -> Parser [Field Position]
elements IndentLevel
ilevel)

-- The body of a field, using either inline style or braces.
--
-- fieldInlineOrBraces   ::= '\\n'? '{' content '}'
--                         | content
fieldInlineOrBraces :: Name Position -> Parser (Field Position)
fieldInlineOrBraces :: Name Position -> ParsecT LexState' () Identity (Field Position)
fieldInlineOrBraces Name Position
name =
      (do Parser ()
openBrace
          [FieldLine Position]
ls <- LexerMode
-> Parser [FieldLine Position] -> Parser [FieldLine Position]
forall p. LexerMode -> Parser p -> Parser p
inLexerMode (Int -> LexerMode
LexerMode Int
in_field_braces) (Parser (FieldLine Position) -> Parser [FieldLine Position]
forall a.
ParsecT LexState' () Identity a
-> ParsecT LexState' () Identity [a]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
many Parser (FieldLine Position)
fieldContent)
          Parser ()
closeBrace
          Field Position -> ParsecT LexState' () Identity (Field Position)
forall a. a -> ParsecT LexState' () Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (Name Position -> [FieldLine Position] -> Field Position
forall ann. Name ann -> [FieldLine ann] -> Field ann
Field Name Position
name [FieldLine Position]
ls))
  ParsecT LexState' () Identity (Field Position)
-> ParsecT LexState' () Identity (Field Position)
-> ParsecT LexState' () Identity (Field Position)
forall a.
ParsecT LexState' () Identity a
-> ParsecT LexState' () Identity a
-> ParsecT LexState' () Identity a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (do [FieldLine Position]
ls <- LexerMode
-> Parser [FieldLine Position] -> Parser [FieldLine Position]
forall p. LexerMode -> Parser p -> Parser p
inLexerMode (Int -> LexerMode
LexerMode Int
in_field_braces) ([FieldLine Position]
-> Parser [FieldLine Position] -> Parser [FieldLine Position]
forall s (m :: * -> *) t a u.
Stream s m t =>
a -> ParsecT s u m a -> ParsecT s u m a
option [] ((FieldLine Position -> [FieldLine Position])
-> Parser (FieldLine Position) -> Parser [FieldLine Position]
forall a b.
(a -> b)
-> ParsecT LexState' () Identity a
-> ParsecT LexState' () Identity b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\FieldLine Position
l -> [FieldLine Position
l]) Parser (FieldLine Position)
fieldContent))
          Field Position -> ParsecT LexState' () Identity (Field Position)
forall a. a -> ParsecT LexState' () Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (Name Position -> [FieldLine Position] -> Field Position
forall ann. Name ann -> [FieldLine ann] -> Field ann
Field Name Position
name [FieldLine Position]
ls))


-- | Parse cabal style 'B8.ByteString' into list of 'Field's, i.e. the cabal AST.
readFields :: B8.ByteString -> Either ParseError [Field Position]
readFields :: ByteString -> Either ParseError [Field Position]
readFields ByteString
s = (([Field Position], [LexWarning]) -> [Field Position])
-> Either ParseError ([Field Position], [LexWarning])
-> Either ParseError [Field Position]
forall a b. (a -> b) -> Either ParseError a -> Either ParseError b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ([Field Position], [LexWarning]) -> [Field Position]
forall a b. (a, b) -> a
fst (ByteString -> Either ParseError ([Field Position], [LexWarning])
readFields' ByteString
s)

-- | Like 'readFields' but also return lexer warnings
readFields' :: B8.ByteString -> Either ParseError ([Field Position], [LexWarning])
readFields' :: ByteString -> Either ParseError ([Field Position], [LexWarning])
readFields' ByteString
s = do
    Parsec LexState' () ([Field Position], [LexWarning])
-> [Char]
-> LexState'
-> Either ParseError ([Field Position], [LexWarning])
forall s t a.
Stream s Identity t =>
Parsec s () a -> [Char] -> s -> Either ParseError a
parse Parsec LexState' () ([Field Position], [LexWarning])
parser [Char]
"the input" LexState'
lexSt
  where
    parser :: Parsec LexState' () ([Field Position], [LexWarning])
parser = do
        [Field Position]
fields <- Parser [Field Position]
cabalStyleFile
        [LexWarning]
ws     <- Parser [LexWarning]
getLexerWarnings
        ([Field Position], [LexWarning])
-> Parsec LexState' () ([Field Position], [LexWarning])
forall a. a -> ParsecT LexState' () Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Field Position]
fields, [LexWarning]
ws)

    lexSt :: LexState'
lexSt = LexState -> LexState'
mkLexState' (ByteString -> LexState
mkLexState ByteString
s)

#ifdef CABAL_PARSEC_DEBUG
parseTest' :: Show a => Parsec LexState' () a -> SourceName -> B8.ByteString -> IO ()
parseTest' p fname s =
    case parse p fname (lexSt s) of
      Left err -> putStrLn (formatError s err)

      Right x  -> print x
  where
    lexSt = mkLexState' . mkLexState

parseFile :: Show a => Parser a -> FilePath -> IO ()
parseFile p f = B8.readFile f >>= \s -> parseTest' p f s

parseStr  :: Show a => Parser a -> String -> IO ()
parseStr p = parseBS p . B8.pack

parseBS  :: Show a => Parser a -> B8.ByteString -> IO ()
parseBS p = parseTest' p "<input string>"

formatError :: B8.ByteString -> ParseError -> String
formatError input perr =
    unlines
      [ "Parse error "++ show (errorPos perr) ++ ":"
      , errLine
      , indicator ++ errmsg ]
  where
    pos       = errorPos perr
    ls        = lines' (T.decodeUtf8With T.lenientDecode input)
    errLine   = T.unpack (ls !! (sourceLine pos - 1))
    indicator = replicate (sourceColumn pos) ' ' ++ "^"
    errmsg    = showErrorMessages "or" "unknown parse error"
                                  "expecting" "unexpected" "end of file"
                                  (errorMessages perr)

-- | Handles windows/osx/unix line breaks uniformly
lines' :: T.Text -> [T.Text]
lines' s1
  | T.null s1 = []
  | otherwise = case T.break (\c -> c == '\r' || c == '\n') s1 of
                  (l, s2) | Just (c,s3) <- T.uncons s2
                         -> case T.uncons s3 of
                              Just ('\n', s4) | c == '\r' -> l : lines' s4
                              _               -> l : lines' s3
                          | otherwise -> [l]
#endif

eof :: Parser ()
eof :: Parser ()
eof = Parser LToken -> Parser ()
notFollowedBy Parser LToken
forall s (m :: * -> *) t u.
(Stream s m t, Show t) =>
ParsecT s u m t
anyToken Parser () -> [Char] -> Parser ()
forall s u (m :: * -> *) a.
ParsecT s u m a -> [Char] -> ParsecT s u m a
<?> [Char]
"end of file"
  where
    notFollowedBy :: Parser LToken -> Parser ()
    notFollowedBy :: Parser LToken -> Parser ()
notFollowedBy Parser LToken
p = Parser () -> Parser ()
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m a
try (    (do L Position
_ Token
t <- Parser LToken -> Parser LToken
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m a
try Parser LToken
p; [Char] -> Parser ()
forall s (m :: * -> *) t u a.
Stream s m t =>
[Char] -> ParsecT s u m a
unexpected (Token -> [Char]
describeToken Token
t))
                           Parser () -> Parser () -> Parser ()
forall a.
ParsecT LexState' () Identity a
-> ParsecT LexState' () Identity a
-> ParsecT LexState' () Identity a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> () -> Parser ()
forall a. a -> ParsecT LexState' () Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return ())