{-# LANGUAGE UnicodeSyntax, ScopedTypeVariables, FlexibleInstances, TypeSynonymInstances, MultiParamTypeClasses, FlexibleContexts, OverlappingInstances, GADTs, TypeOperators, TypeFamilies, PatternGuards, DeriveDataTypeable #-}
{-# OPTIONS_GHC -O0 #-}

{- C++ is notoriously hard to parse. There are ambiguities in the grammar that can only be resolved through things like name lookup, which in turn require things like overloading and template instantiation, and so one basically has to implement a complete compiler front-end just to be able to parse.

However, this assumes that one insists on telling the ambiguous constructs apart. In the C++ parser defined in this module, we drop this requirement, and instead just accept that some ambiguous constructs will be parsed arbitrarily as one of their possible interpretations. This means that for something like:

  x*y;

we don't do name lookup to determine whether x is a type or a variable, in order to decide whether this statement is a declaration-statement or an expression-statement. We just parse it as a declaration, because we're especially interested in parsing declarations (since they have names and are natural subjects of edit commands).

Here are some more typical ambiguous constructs:

  int x(y); // If y is a type, this is a function declaration. Otherwise, it's a variable definition.
  x<y> z; // If x is a template, this is a variable declaration. Otherwise, it's an expression-statement.
  x(y); // If x is a type, this is a variable declaration. Otherwise, it's a function call.
  x+(y)(z); // if y is a type, (y)(z) is a cast. Otherwise, it's a function call.

We always prefer parsing things as declarations.

Note that even if we /could/ parse properly with name lookup and all the rest, we wouldn't want to, because we typically want to parse ill-formed code (with type errors, for example) in order to run edit commands on it to make it well-formed.

This C++ parser is probably extremely inefficient. Fortunately, geordi only ever runs it on tiny C++ snippets, so we just don't care.

-}

module Cxx.Parse (Chunk(..), code, charLit, stringLit, makeType, precedence, parseRequest, makeDeclParser, declaratorIdParser, highlight) where

import qualified Data.Char as Char
import qualified Data.List as List
import qualified Data.List.NonEmpty as NeList
import qualified Parsers as P
import qualified Cxx.Show
import Control.Arrow (first, second)
import Control.Applicative (Applicative(..))
import Control.Monad.Fix (fix)
import Control.Monad.Instances ()
import Control.Monad (liftM2, liftM3, when)
import Data.List ((\\))
import Data.List.NonEmpty (NonEmpty(..))
import Data.Generics (Data, Typeable, dataTypeOf)
import Data.Maybe (mapMaybe)
import Data.Function (on)
import Data.Foldable (toList)
import Util ((<<), (.), Convert(..), isIdChar, Finite(..), Phantom(..), cardinals, partitionMaybe, TriBool(..), (.∨.), NeList, neElim, prefixNeList, neInitLast)
import Cxx.Basics
import Cxx.Show (pretty_with_precedence, Highlighter)
import Cxx.Operations (apply, squared, is_primary_TypeSpecifier, parenthesized, specT, split_all_decls, is_pointer_or_reference)
import Prelude hiding ((.))
import Prelude.Unicode
import Control.Monad.Reader (ReaderT(..))
import Parsers ((<?>), (<|>), pzero, spaces, many, optional, choice, sep, many1, symbols, noneOf, lookAhead, symbol, satisfy, optionMaybe, anySymbol, manyTill, many1Till, oneOf, ParserLike, eof, ParseResult(..), getInput, sepBy1, option)
import MemoTrie (memo, Trie(..), PairTrie(..), BoolTrie(..))

-- Custom parsing monad:

data ParseOptions = ParseOptions { makeTypeExtensions :: Bool, pendingCloseAngleBracket :: Bool }

instance Trie ParseOptions (PairTrie BoolTrie BoolTrie) where
  trie f = trie (\(x, y) → f $ ParseOptions x y)
  untrie f (ParseOptions x y) = untrie f (x, y)

defaultParseOptions :: ParseOptions
defaultParseOptions = ParseOptions { makeTypeExtensions = False, pendingCloseAngleBracket = False }

type Parser t = ReaderT ParseOptions (P.Parser t)

instance ParserLike (Parser a) a where
  anySymbol = ReaderT $ const anySymbol
  eof = ReaderT $ const eof
  pzero = ReaderT $ const pzero
  ReaderT p <?> s = ReaderT $ (<?> s) . p
  ReaderT p <|> ReaderT q = ReaderT $ \o → p o <|> q o
  symbols = ReaderT . const . symbols
  satisfy = ReaderT . const . satisfy
  lookAhead (ReaderT p) = ReaderT $ lookAhead . p
  try = id

parseOptions :: Parser t ParseOptions
parseOptions = ReaderT return

-- Some combinators:

silent :: Parser a b → Parser a b
silent (ReaderT f) = ReaderT $ P.silent . f

guarded :: (a → Bool) → Parser t a → Parser t a
guarded f (ReaderT p) = ReaderT $ P.guarded f . p

memoize :: Parser Char a → Parser Char a
memoize (ReaderT p) = ReaderT $ \o → P.Parser $ \s → m (o, s)
  where m = memo $ \(o, s) → P.run_parser (p o) s
    -- Note that we memoize over the whole input string, rather than just the position. This is very simplistic and inefficient, but we don't care. We only use memoization to prevent exponential explosions.

notFollowedBy :: Parser t a → Parser t ()
notFollowedBy (ReaderT p) = ReaderT $ P.notFollowedBy . p

-- Primary module exports

precedence :: String → Either String String
precedence s = either (pretty_with_precedence . split_all_decls) (pretty_with_precedence . split_all_decls) .
  P.parseOrFail p (dropWhile Char.isSpace s) "code"
  where p = runReaderT (parse << eof) defaultParseOptions :: P.Parser Char (Either Expression [Statement])

highlight :: Highlighter → String → String
highlight h s =
  case P.run_parser p (dropWhile Char.isSpace s) of
    ParseSuccess r _ _ _ → Cxx.Show.show_pretty False h r
    ParseFailure{} → s
  where p = runReaderT (parse << eof) defaultParseOptions :: P.Parser Char GeordiRequest

parseRequest :: String → Either String GeordiRequest
parseRequest s = P.parseOrFail (runReaderT (parse << eof) defaultParseOptions) s "request"

makeType :: String → Either String TypeId
makeType s = P.parseOrFail (runReaderT (parse << eof) (defaultParseOptions { makeTypeExtensions = True })) (dropWhile Char.isSpace s) "type description"

-- Chunk/Code parsers

textLit :: ParserLike m Char ⇒ Char → m String
textLit q = (symbol q >>) $ fix $ \h → do
  s ← many $ noneOf [q, '\\']
  c ← anySymbol
  if c == '\\'
    then do d ← anySymbol; r ← h; return $ s ++ ('\\':d:r)
    else return s

rawStringLit :: ParserLike m Char ⇒ m Chunk
rawStringLit = do
  symbols "R\""
  x <- fst . (anySymbol `manyTill` symbol '(')
  y <- fst . (anySymbol `manyTill` P.try (symbols (')' : x) >> symbol '"'))
  return $ RawStringLiteral x y

-- Parsec's Haskell char/string literal parsers consume whitespace, and save the value rather than the denotation.

charLit, stringLit, digits, plain, parens, curlies, squares, multiComment, singleComment :: ParserLike m Char ⇒ m Chunk

charLit = CharLiteral . textLit '\''
stringLit = StringLiteral' . textLit '"'
digits = Plain . (liftM2 (:) (satisfy Char.isDigit) (many (satisfy (\c -> Char.isDigit c || c == '\''))))
plain = Plain . ((:[]) . oneOf ";\\" <|> toList . many1 punct <|> toList . many1 (satisfy Char.isAlpha))
  where
    punct = do
      c <- satisfy (\c -> not (Char.isAlphaNum c) && not (c `elem` "'\"{([])};\\"))
      when (c == '/') $ lookAhead (noneOf "*/") >> return ()
      return c
parens = Parens . (symbol '(' >> code << symbol ')')
curlies = Curlies . (symbol '{' >> code << symbol '}')
squares = Squares . (symbol '[' >> code << symbol ']')
multiComment = MultiComment . (symbols "/*" >> fst . manyTill anySymbol (symbols "*/"))
singleComment = SingleComment . (symbols "//" >> many (noneOf "\\"))

code :: ParserLike m Char ⇒ m Code
code = many $ (<?> "balanced code") $
  multiComment <|> singleComment <|> charLit <|> parens <|> curlies <|> squares
  <|> stringLit <|> rawStringLit <|> digits <|> plain
  -- Uncovers just enough structure for Request.hs to find the split positions in "<< ...; ..." and "{ ... } ..." requests and to implement --resume.

-- Misc parsers.

kwd :: String → Parser Char White
kwd x = symbols x >> notFollowedBy (satisfy isIdChar) >> parse

makeDeclParser :: P.Parser Char MakeDeclaration
makeDeclParser = runReaderT parse (defaultParseOptions { makeTypeExtensions = True })

declaratorIdParser :: P.Parser Char DeclaratorId
declaratorIdParser = runReaderT parse defaultParseOptions

anyOperator :: Parser Char (OperatorTok, White)
anyOperator = (<?> "operator") $ do
  o ← parseOptions
  liftM2 (,) (choice $ if pendingCloseAngleBracket o then pcab else normal) parse
  where
    normal = map (\x → symbols (show x) >> return x) $ List.sortBy (flip compare `on` length . show) (all_values :: [OperatorTok])
    pcab = map (\x → symbols (show x) >> return x) $ List.sortBy (flip compare `on` length . show) $ (all_values :: [OperatorTok]) \\ [CloseTwoAngles, CloseAngle]
      -- Profiling showed that having these two separate makes a huge difference in space/time efficiency.

op :: OperatorTok → Parser Char White
op o = (<?> operatorTokName o) $ snd . guarded ((== o) . fst) anyOperator

class Data a ⇒ Parse a where
  parse :: Parser Char a
  parse = autoname_parse <?> Cxx.Show.dataType_productionName (dataTypeOf (undefined :: a))
  autoname_parse :: Parser Char a
  autoname_parse = parse
    -- autoname_parse must never be used--it is merely a hook for parse.

instance (Data a, Finite a, SingleTokenType a) ⇒ Parse (a, White) where parse = (<?> token_class_name (Phantom :: Phantom a)) $ choice $ (\v → (,) v . either kwd op (token v)) . all_values
instance Parse White where
  parse = silent $ White . concat . many (
    (symbols "/*" >> ("/*" ++) . (++ "*/") . fst . manyTill anySymbol (symbols "*/")) <|>
    (symbols "//" >> ("//" ++) . getInput) <|> symbols " ")

instance Parse a ⇒ Parse [a] where parse = many parse
instance Parse a ⇒ Parse (Maybe a) where parse = optionMaybe parse
instance Parse a ⇒ Parse (Enclosed a) where parse = Enclosed . parse
instance (Parse a, Parse b) ⇒ Parse (a, b) where parse = auto2 (,)
instance (Parse a, Parse b, Parse c) ⇒ Parse (a, b, c) where parse = auto3 (,,)
instance (Parse a, Parse b, Parse c, Parse d) ⇒ Parse (a, b, c ,d) where parse = auto4 (,,,)
instance Parse a ⇒ Parse (Commad a) where parse = liftM2 Commad parse (many (liftM2 (,) parse parse))
instance (Parse a, Parse b) ⇒ Parse (Either a b) where parse = Left . parse <|> Right . parse
instance Parse a ⇒ Parse (Angled a) where parse = liftM3 Angled parse (ReaderT $ \o → runReaderT parse (o { pendingCloseAngleBracket = True })) (liftM2 (,) (symbol '>' >> return CloseAngle_) parse)
instance Parse a ⇒ Parse (Squared a) where parse = liftM3 Squared parse (ReaderT $ \o → runReaderT parse $ o { pendingCloseAngleBracket = False }) parse
instance Parse a ⇒ Parse (Curlied a) where parse = liftM3 Curlied parse (ReaderT $ \o → runReaderT parse $ o { pendingCloseAngleBracket = False }) parse
instance Parse a ⇒ Parse (Parenthesized a) where parse = parseParenthesized parse
instance Parse () where parse = return ()
instance Parse a ⇒ Parse (NeList a) where parse = many1 parse

parseParenthesized :: Parser Char (Enclosed a) → Parser Char (Parenthesized a)
parseParenthesized p = liftM3 Parenthesized parse (ReaderT $ \o → runReaderT p $ o { pendingCloseAngleBracket = False }) parse

an :: Parser Char (Maybe White)
an = silent $ optional $ kwd "an" <|> kwd "a"

pluralP :: String → Parser Char ()
pluralP s = (>> return ()) $ kwd s <|> kwd (s ++ "s")

delim :: Parser Char ()
delim = (op CommaTok >> optional (kwd "and") >> return ()) <|> (kwd "and" >> return ())

takingP :: Parser Char ParameterDeclarationClause
takingP =
  ((kwd "nothing" <|> (kwd "no" >> kwd "arguments")) >> return (ParameterDeclarationClause Nothing Nothing)) <|> mkParameterDeclarationClause . concat . sepBy1 takingClause (delim >> ((kwd "returning" >> pzero) <|> return ()))

commad :: NeList x → Commad x
commad l = Commad (NeList.head l) $ (,) (CommaOp, White " ") . NeList.tail l

mkParameterDeclarationClause :: [ParameterDeclaration] → ParameterDeclarationClause
mkParameterDeclarationClause l =
  ParameterDeclarationClause (case l of [] → Nothing; h:t → (Just $ ParameterDeclarationList $ commad $ h :| t)) Nothing

instance Parse (CvQualifier, White) where
  parse = (<?> "cv-qualifier") $ do
    b ← makeTypeExtensions . parseOptions
    (if b then (,) Const . kwd "constant" else pzero) <|> (,) Const . kwd "const" <|> (,) Volatile . kwd "volatile"

instance Parse CvQualifierSeq where autoname_parse = auto1 CvQualifierSeq

takingClause :: Parser Char [ParameterDeclaration]
takingClause = (do
  IntegerLiteral s ← parse
  let (n :: Integer) = read s
  if n > 10 then pzero else replicate (fromInteger n) . parse) <|> (:[]) . (an >> parse)

instance Parse MakeDeclaration where
  parse = (<?> "type description") $ (an >>) $ (longlong .) $ flip fix [] $ \self specs → do
    pspec ← parsePrimarySpec
    sspecs ← many parseSecondarySpec
    (\x → MakeDeclaration (reverse specs ++ pspec : sspecs) x Indeterminate) . parse
    <|> (((: specs) . parseSecondarySpec) >>= self)
    <|> do
      kwd "pure"
      let virtSpec = MakeSpecifier_DeclSpecifier $ DeclSpecifier_FunctionSpecifier (Virtual, White " ")
      do { MakeDeclaration l m _ ← self specs; return $ MakeDeclaration (virtSpec : l) m Definitely } <|> return (MakeDeclaration (virtSpec : specs) Nothing Definitely)
    <|> do
      kwd "impure" <|> kwd "nonpure"
      do { MakeDeclaration l m _ ← self specs; return $ MakeDeclaration l m DefinitelyNot } <|> return (MakeDeclaration specs Nothing DefinitelyNot)
    <|> do
    let (noncvs, cvs) = partitionMaybe (convert :: MakeSpecifier → Maybe (CvQualifier, White)) specs
    (x, y) ← type_desc
    return $ (\(p, q) → MakeDeclaration p q Indeterminate) $ apply (map fst cvs) $ case y of
      Left s → (noncvs ++ MakeSpecifier_DeclSpecifier . DeclSpecifier_TypeSpecifier . (x ++ [s]), Nothing)
      Right ad → (noncvs ++ MakeSpecifier_DeclSpecifier . DeclSpecifier_TypeSpecifier . x, Just ad)
    <|> (\x → MakeDeclaration specs x Indeterminate) . (if null specs then Just . parse else parse)
    where
      longlong m@(MakeDeclaration l x y)
        | (p, q) ← List.partition (== convert LongSpec) l, length p ≥ 2 = MakeDeclaration (LongLong : q) x y
        | otherwise = m

literalArrayBound :: IntegerLiteral → ConstantExpression
literalArrayBound = ConstantExpression . ConditionalExpression_LogicalOrExpression . LogicalOrExpression_LogicalAndExpression . LogicalAndExpression_InclusiveOrExpression . InclusiveOrExpression_ExclusiveOrExpression . ExclusiveOrExpression_AndExpression . AndExpression_EqualityExpression . EqualityExpression_RelationalExpression . RelationalExpression_ShiftExpression . ShiftExpression_AdditiveExpression . AdditiveExpression_MultiplicativeExpression . MultiplicativeExpression_PmExpression . PmExpression_CastExpression . CastExpression_UnaryExpression . UnaryExpression_PostfixExpression . PostfixExpression_PrimaryExpression . PrimaryExpression_Literal . flip Literal_IntegerLiteral (White "")

type_desc :: Parser Char ([TypeSpecifier], Either TypeSpecifier PtrAbstractDeclarator)
  -- Todo: Document this type
type_desc = (<?> "type description") $ do
      o ← (pluralP "pointer" >> return (PtrOperator_Ptr (StarOperator, White "") Nothing))
        <|> (\k → PtrOperator_Ref (k, White "")) . (((kwd "rvalue" >> return Rvalue) <|> (optional (kwd "lvalue") >> return Lvalue)) << pluralP "reference")
      (kwd "to" >> an >> second Right . apply o . specdDesc) <|> ((,) [] . Right . flip apply (PtrAbstractDeclarator o Nothing) . (parse :: Parser Char (Maybe PtrAbstractDeclarator)))
    <|> do
      pluralP "array"
      let d = PtrAbstractDeclarator_NoptrAbstractDeclarator . NoptrAbstractDeclarator Nothing . Right . squared
      do
        kwd "of"; n ← ((d . Just . literalArrayBound . parse) << spaces) <|> return (d Nothing)
        second Right . apply n . specdDesc
       <|> do
        mad ← parse :: Parser Char (Maybe PtrAbstractDeclarator)
        return ([], Right $ apply mad (d Nothing))
    <|> liftM2 (flip apply) (op OpenParen >> specdDesc << op CloseParen) (parse :: Parser Char (Maybe PtrAbstractDeclarator))
    <|> do
      pluralP "function"
      let function_declarator taking = PtrAbstractDeclarator_NoptrAbstractDeclarator $ NoptrAbstractDeclarator Nothing (Left $ ParametersAndQualifiers (parenthesized taking) Nothing Nothing Nothing)
      do
        taking ← kwd "taking" >> takingP
        do
          second Right . apply (function_declarator taking) . (optional delim >> kwd "returning" >> an >> specdDesc) <|> return ([], Right $ function_declarator taking)
        <|> do
        second Right . liftM2 (flip apply) (kwd "returning" >> an >> specdDesc) (function_declarator . ((optional delim >> kwd "taking" >> takingP) <|> return (mkParameterDeclarationClause [])))
        <|> do
        (,) [] . Right . flip apply (function_declarator $ mkParameterDeclarationClause []) . (parse :: Parser Char (Maybe PtrAbstractDeclarator))
  where
    specdDesc :: Parser Char ([TypeSpecifier], Either TypeSpecifier PtrAbstractDeclarator)
    specdDesc = (<?> "type description") $ flip fix [] $ \self specs → do
      morespecs ← liftM2 (:|) parsePrimarySpec (many parseSecondarySpec)
      let ne = prefixNeList specs morespecs
      mad ← parse :: Parser Char (Maybe PtrAbstractDeclarator)
      return $ case mad of
        Nothing → second Left $ neInitLast ne
        Just ad → (toList ne, Right ad)
     <|> do
      sspec ← parseSecondarySpec
      self (specs ++ [sspec]) <|> return ([], Left sspec)
     <|> do
      let (noncvs, cvs) = partitionMaybe (convert :: TypeSpecifier → Maybe (CvQualifier, White)) specs
      first (noncvs ++) . apply (map fst cvs) . type_desc

with_default :: [TypeSpecifier] → NeList TypeSpecifier
with_default [] = return specT
with_default l@(h:t) = if any is_primary_TypeSpecifier l then h :| t else specT :| l

instance Parse GeordiRequestWithoutWhite where
  parse = auto3 GeordiRequest_Print <|> auto2 GeordiRequest_Block <|> auto1 GeordiRequest_TU <|> auto2 GeordiRequest_Call

parseAnyMixOf :: Parser t a → Parser t b → Parser t (AnyMixOf a b)
parseAnyMixOf p q = (p >>= \x → MixAB x . q <|> return (MixA x)) <|> (q >>= \y → MixBA y . p <|> return (MixB y)) <|> return MixNone

instance (Parse a, Parse b) ⇒ Parse (AnyMixOf a b) where parse = parseAnyMixOf parse parse

instance Parse OptQualified where parse = auto2 OptQualified <?> "optional qualification"

auto1 :: (Parse a) ⇒ (a → b) → Parser Char b
auto1 f = f . parse
auto2 :: (Parse a, Parse b) ⇒ (a → b → c) → Parser Char c
auto2 f = auto1 f <*> parse
auto3 :: (Parse a, Parse b, Parse c) ⇒ (a → b → c → d) → Parser Char d
auto3 f = auto2 f <*> parse
auto4 :: (Parse a, Parse b, Parse c, Parse d) ⇒ (a → b → c → d → e) → Parser Char e
auto4 f = auto3 f <*> parse
auto5 :: (Parse a, Parse b, Parse c, Parse d, Parse e) ⇒ (a → b → c → d → e → f) → Parser Char f
auto5 f = auto4 f <*> parse
auto6 :: (Parse a, Parse b, Parse c, Parse d, Parse e, Parse f) ⇒ (a → b → c → d → e → f → g) → Parser Char g
auto6 f = auto5 f <*> parse


-- Parse instances for all the grammar productions.

-- A.1 Keywords [gram.key]

instance Parse TemplateName where autoname_parse = auto1 TemplateName

-- A.2 Lexical conventions [gram.lex]

instance Parse Identifier where
  autoname_parse = do
    b ← makeTypeExtensions . parseOptions
    let k = keywords ++ if b then make_type_keywords else []
    liftM2 Identifier (guarded (not . (`elem` k)) $ liftM2 (:) (satisfy $ Char.isAlpha .∨. (== '_')) (many $ satisfy isIdChar)) parse

instance Parse ClassName where autoname_parse = auto1 ClassName_TemplateId <|> auto1 ClassName_Identifier
instance Parse TypeName where autoname_parse = auto1 TypeName_ClassName

instance Parse FloatingLiteral where
  autoname_parse = (FloatingLiteral .) $ (>++> optSuffix) $
    (symbols "." >++> (toList . many1 digit) >++> option "" exponentPart) <|>
    ((toList . many1 digit) >++> ((symbols "." >++> many digit >++> option "" exponentPart >++> optSuffix) <|> exponentPart))
    where
      (>++>) = liftM2 (++)
      digit = satisfy Char.isDigit
      optSuffix = option "" $ (:[]) . (symbol 'f' <|> symbol 'l' <|> symbol 'F' <|> symbol 'L')
      exponentPart = (symbols "e" <|> symbols "E") >++> option "" (symbols "+" <|> symbols "-") >++> (toList . many1 digit)
instance Parse IntegerLiteral where
  autoname_parse = (IntegerLiteral .) $ (p <|>) $ do
    b ← makeTypeExtensions . parseOptions
    if b then choice $ zipWith (\n s → kwd s >> return (show n)) [0::Int ..] cardinals else pzero
   where p = liftM2 (:) (satisfy Char.isDigit) (many (satisfy Char.isAlphaNum) << notFollowedBy (satisfy isIdChar))
instance Parse EncodingPrefix where
  parse = (symbols "u8" >> return EncodingPrefix_u8) <|> (symbol 'u' >> return EncodingPrefix_u) <|> (symbol 'U' >> return EncodingPrefix_U) <|> (symbol 'L' >> return EncodingPrefix_L)
instance Parse SingleStringLiteral where parse = liftM2 SingleStringLiteral parse (textLit '"')
instance Parse StringLiteral where autoname_parse = StringLiteral . many1 (auto2 (,))
instance Parse CharacterLiteralKind where parse = (symbol 'u' >> return CharacterLiteralKind_u) <|> (symbol 'U' >> return CharacterLiteralKind_U) <|> (symbol 'L' >> return CharacterLiteralKind_L) <|> return CharacterLiteral_Plain
instance Parse CharacterLiteral where parse = liftM2 CharacterLiteral parse (textLit '\'')
instance Parse Literal where
  autoname_parse = auto2 Literal_CharacterLiteral <|> auto1 Literal_StringLiteral <|> auto2 Literal_FloatingLiteral <|> auto2 Literal_IntegerLiteral <|> BooleanLiteral True . kwd "true" <|> BooleanLiteral False . kwd "false" <|> PointerLiteral . kwd "nullptr"

-- A.3 Basic concepts [gram.basic]

instance Parse TranslationUnit where parse = TranslationUnit . parse

-- A.4 Expressions [gram.expr]

instance Parse PrimaryExpression where
  autoname_parse =
    auto1 PrimaryExpression_This <|> auto1 PrimaryExpression_Literal <|>
    auto1 PrimaryExpression_Expression <|> auto1 PrimaryExpression_IdExpression <|>
    auto1 PrimaryExpression_LambdaExpression
instance Parse IdExpression where autoname_parse = auto1 IdExpression
instance Parse UnqualifiedId where
  autoname_parse =
    (parse >>= \w → (UnqualifiedId_OperatorFunctionId . OperatorFunctionId w . parse <|> UnqualifiedId_ConversionFunctionId . ConversionFunctionId w . parse))
    <|> auto1 UnqualifiedId_TemplateId <|> auto1 UnqualifiedId_Identifier <|> auto2 UnqualifiedId_Destructor
instance Parse QualifiedId where
  autoname_parse = (do
    w ← parse
    auto3 (NestedUnqualifiedId (Just w)) <|> GlobalIdentifier w . parse <|> GlobalOperatorFunctionId w . parse <|> GlobalTemplateId w . parse
   ) <|> auto3 (NestedUnqualifiedId Nothing)
instance Parse NestedNameSpecifier where
  autoname_parse = liftM2 (foldl (flip ($)))
    (auto2 NestedNameSpecifier_TypeName)
    (many $ auto3 (\x y z u → NestedNameSpecifier_SimpleTemplateId u x y z) <|> auto2 (\x y z → NestedNameSpecifier_Identifier z x y))
      -- We can't distinguish a simple class-name from a namespace-name anyway, so we only try to parse a type-name here.
instance Parse LambdaExpression where autoname_parse = auto3 LambdaExpression
instance Parse LambdaIntroducer where autoname_parse = auto1 LambdaIntroducer
instance Parse LambdaCapture where
  autoname_parse = (do
      def ← parse
      let sofar = LambdaCapture (Just def)
      m ← optionMaybe (liftM2 (,) parse parse)
      return $ case m of
        Just ((c,w), l) → sofar (Just (c, w)) (Just l)
        Nothing → sofar Nothing Nothing
    ) <|> auto1 (LambdaCapture Nothing Nothing . Just)
instance Parse CaptureDefault where autoname_parse = auto1 CaptureDefault
instance Parse CaptureList where autoname_parse = auto1 CaptureList
instance Parse Capture where autoname_parse = auto2 Capture_Identifier <|> auto1 Capture_This
instance Parse LambdaDeclarator where autoname_parse = auto4 LambdaDeclarator
instance Parse PostfixExpression where
  autoname_parse = liftM2 (foldl $ flip ($)) basic $ many $ (<?> "postfix operator") $
      auto3 (\o t e' e → PostfixExpression_Member e o t e') <|> flip PostfixExpression_IncDec . parse <|> flip PostfixExpression_FunctionCall . parse <|> flip PostfixExpression_Squared . parse <|> auto2 (\o n e → PostfixExpression_PseudoDestructor e o n)
    where
     basic = auto3 PostfixExpression_NewStyleCast <|> auto2 PostfixExpression_Conversion <|> auto2 PostfixExpression_TypeId <|> auto1 PostfixExpression_PrimaryExpression
instance Parse ExpressionList where autoname_parse = auto1 ExpressionList
instance Parse PseudoDestructorName where
  autoname_parse = do
    w ← parse
    mnns ← parse
    maybe pzero (auto5 . PseudoDestructorName_InTemplate w) mnns <|>
      auto2 (PseudoDestructorName (OptQualified w mnns)) <|>
      auto4 (PseudoDestructorName_InTypeName (OptQualified w mnns))
simpleBinaryGroup :: (Parse (b, White), Parse a) ⇒ (a1 → (b, White) → a → a1) → (a → a1) → Parser Char a1
simpleBinaryGroup c l = do
  (e, f) ← sep parse (parse <?> "binary operator")
  return $ foldl (\z ((o, w), y) → c z (o, w) y) (l e) f
simplerBinaryGroup :: (Parse a) ⇒ Parser Char d → (a1 → d → a → a1) → (a → a1) → Parser Char a1
simplerBinaryGroup p c l = do
    (e, f) ← sep parse (p <?> "binary operator")
    return $ foldl (\z (w, y) → c z w y) (l e) f
instance Parse UnaryExpression where
  autoname_parse =
    (parse >>= \w → (UnaryExpression_Sizeof_TypeId w . parse <|> (UnaryExpression_Sizeof_UnaryExpression w . parse))) <|>
    auto2 UnaryExpression_AlignOf <|> auto2 UnaryExpression <|> UnaryExpression_NewExpression . parse <|> UnaryExpression_DeleteExpression . parse <|> UnaryExpression_PostfixExpression . parse
instance Parse NewInitializer where autoname_parse = auto1 NewInitializer_ExpressionList <|> auto1 NewInitializer_BracedInitList
instance Parse NewExpression where autoname_parse = auto5 NewExpression
instance Parse NewPlacement where autoname_parse = auto1 NewPlacement
instance Parse NewTypeId where autoname_parse = auto2 NewTypeId
instance Parse NewDeclarator where autoname_parse = auto2 NewDeclarator_PtrOperator <|> auto1 NewDeclarator_NoptrNewDeclarator
instance Parse NoptrNewDeclarator where parse = liftM2 NoptrNewDeclarator parse (reverse . parse)
instance Parse DeleteExpression where autoname_parse = auto4 DeleteExpression
instance Parse ThrowExpression where autoname_parse = auto2 ThrowExpression
instance Parse CastExpression where autoname_parse = auto2 CastExpression_Cast <|> CastExpression_UnaryExpression . parse
instance Parse PmExpression where autoname_parse = simpleBinaryGroup PmExpression PmExpression_CastExpression
instance Parse MultiplicativeExpression where autoname_parse = simpleBinaryGroup MultiplicativeExpression MultiplicativeExpression_PmExpression
instance Parse AdditiveExpression where autoname_parse = simpleBinaryGroup AdditiveExpression AdditiveExpression_MultiplicativeExpression
instance Parse ShiftExpression where autoname_parse = simpleBinaryGroup ShiftExpression ShiftExpression_AdditiveExpression
instance Parse RelationalExpression where autoname_parse = simpleBinaryGroup RelationalExpression RelationalExpression_ShiftExpression
instance Parse EqualityExpression where autoname_parse = simpleBinaryGroup EqualityExpression EqualityExpression_RelationalExpression
instance Parse AndExpression where autoname_parse = simplerBinaryGroup parse AndExpression AndExpression_EqualityExpression
instance Parse ExclusiveOrExpression where autoname_parse = simplerBinaryGroup parse ExclusiveOrExpression ExclusiveOrExpression_AndExpression
instance Parse InclusiveOrExpression where autoname_parse = simplerBinaryGroup parse InclusiveOrExpression InclusiveOrExpression_ExclusiveOrExpression
instance Parse LogicalAndExpression where autoname_parse = simplerBinaryGroup parse LogicalAndExpression LogicalAndExpression_InclusiveOrExpression
instance Parse LogicalOrExpression where autoname_parse = simplerBinaryGroup parse LogicalOrExpression LogicalOrExpression_LogicalAndExpression
instance Parse ConditionalExpression where autoname_parse = ConditionalExpression_LogicalOrExpression . parse -- Todo: This is no good, I think.
instance Parse AssignmentExpression where
  autoname_parse = (AssignmentExpression_ThrowExpression . parse <|>) $ do
    e ← parse
    AssignmentExpression_ConditionalExpression . auto4 (ConditionalExpression e) <|> auto2 (AssignmentExpression e) <|> return (AssignmentExpression_ConditionalExpression $ ConditionalExpression_LogicalOrExpression e)
instance Parse Expression where autoname_parse = simplerBinaryGroup parse Expression_Comma Expression_AssignmentExpression
instance Parse ConstantExpression where autoname_parse = auto1 ConstantExpression

-- A.5 Statements [gram.stmt]

instance Parse Statement where
  autoname_parse = auto1 Statement_CompoundStatement <|> auto1 Statement_JumpStatement <|> auto1 Statement_SelectionStatement <|> auto1 Statement_IterationStatement <|> auto1 Statement_DeclarationStatement <|> auto1 Statement_ExpressionStatement <|> auto1 Statement_TryBlock <|> auto1 Statement_Labeled

instance Parse Label where parse = auto1 IdentifierLabel <|> auto2 CaseLabel <|> auto1 DefaultLabel
instance Parse LabeledStatement where autoname_parse = auto3 LabeledStatement
instance Parse IterationStatement where autoname_parse = auto3 WhileStatement <|> auto5 DoWhileStatement <|> auto3 ForStatement <|> auto3 RangeForStatement
instance Parse ForInitStatement where autoname_parse = auto1 ForInitStatement_SimpleDeclaration <|> auto1 ForInitStatement_ExpressionStatement
instance Parse ForRangeInitializer where autoname_parse = auto1 ForRangeInitializer_Expression <|> auto1 ForRangeInitializer_BracedInitList
instance Parse ForRangeDeclaration where autoname_parse = uncurry ForRangeDeclaration . first DeclSpecifierSeq . many1Till parse parse
instance Parse SelectionStatement where autoname_parse = auto4 IfStatement <|> auto3 SwitchStatement
instance Parse JumpStatement where autoname_parse = auto2 BreakStatement <|> auto2 ContinueStatement <|> auto3 ReturnStatement <|> auto3 GotoStatement
instance Parse ExpressionStatement where autoname_parse = auto2 ExpressionStatement
instance Parse Condition where autoname_parse = auto1 Condition_Expression <|> auto3 Condition_Declaration
instance Parse StatementSeq where autoname_parse = auto1 StatementSeq
instance Parse CompoundStatement where autoname_parse = auto1 CompoundStatement
instance Parse DeclarationStatement where autoname_parse = auto1 DeclarationStatement

-- A.6 Declarations [gram.dcl]

instance Parse DeclarationSeq where autoname_parse = auto1 DeclarationSeq
instance Parse Declaration where autoname_parse = auto1 Declaration_BlockDeclaration <|> auto1 Declaration_FunctionDefinition <|> auto1 Declaration_ExplicitSpecialization <|> auto1 Declaration_ExplicitInstantiation <|> auto1 Declaration_LinkageSpecification <|> auto1 Declaration_NamespaceDefinition <|> auto1 Declaration_TemplateDeclaration
instance Parse BlockDeclaration where autoname_parse = auto1 BlockDeclaration_SimpleDeclaration <|> auto1 BlockDeclaration_AsmDefinition <|> auto1 BlockDeclaration_NamespaceAliasDefinition <|> auto1 BlockDeclaration_UsingDeclaration <|> auto1 BlockDeclaration_UsingDirective <|> auto1 BlockDeclaration_StaticAssertDeclaration <|> auto1 BlockDeclaration_AliasDeclaration
instance Parse UsingDirective where parse = auto5 UsingDirective
instance Parse AliasDeclaration where parse = auto5 AliasDeclaration
instance Parse StaticAssertDeclaration where parse = auto3 StaticAssertDeclaration
instance Parse NamespaceAliasDefinition where parse = auto6 NamespaceAliasDefinition
instance Parse NamespaceName where parse = NamespaceName_OriginalNamespaceName . OriginalNamespaceName . parse
instance Parse AsmDefinition where parse = auto3 AsmDefinition
  -- Things like AsmDefinition that only occur as specializations of more general productions need no expectation string.

-- A simple-declaration may have no decl-specifiers, for example in "template <typename T> X(T);". However, if we just naively use manyTill, we will accidentally parse the two statements in { i; i = 0; } as declarations. We therefore first try to parse declarators valid for simple-declarations without decl-specifiers, and if that fails, we unconditionally parse at least one decl-specifier and proceed with arbitrary declarators.

data SpecialNoptrDeclarator = SpecialNoptrDeclarator { specialNoptrDeclarator :: NoptrDeclarator } deriving (Data, Typeable)

instance Parse SpecialNoptrDeclarator where
  parse = auto2 $ \x y → SpecialNoptrDeclarator $ NoptrDeclarator_WithParams (NoptrDeclarator_Id x) y
    -- Todo: This is too simplistic. It will fail to parse (obscure) things like "(X)();" and "(X());".

instance Parse SimpleDeclaration where
  parse = liftM2 (SimpleDeclaration Nothing) (Just . InitDeclaratorList . ((convert . specialNoptrDeclarator) .) . parse) parse <|> do
    (specs, (decls, semicolon)) ← many1Till parse (liftM2 (,) parse parse)
    return $ SimpleDeclaration (Just $ DeclSpecifierSeq specs) decls semicolon

instance Parse UsingDeclaration where parse = parse >>= \w → auto5 (UsingDeclaration_Nested w) <|> auto3 (UsingDeclaration_NonNested w)
instance Parse AlignmentSpecifier where autoname_parse = auto2 AlignmentSpecifier
instance Parse (BasicType, White) where
  parse = do
    b ← makeTypeExtensions . parseOptions
    if not b
      then choice $ (\v → (,) v . either kwd op (token v)) . all_values
      else choice $ map (\(v, k) → (,) v . kwd k) $
        ((,) Int' . ["ints", "integer", "integers"]) ++
        ((,) Char' . ["chars", "character", "characters"]) ++
        ((,) Bool' . ["bools", "boolean", "booleans"]) ++
        [(Float', "floats"), (Double', "doubles"), (Void, "nothing")] ++
        mapMaybe (\v → either (Just . (,) v) (const Nothing) (token v)) all_values
instance Parse SimpleTypeSpecifier where
  autoname_parse =
      SimpleTypeSpecifier_Auto . parse <|> SimpleTypeSpecifier_BasicType . parse
    <|> liftM2 SimpleTypeSpecifier_DeclType parse parse <|> LengthSpec . parse <|> SignSpec . parse
    <|> do
      w ← parse
      (parse >>= \nns → (auto2 (SimpleTypeSpecifier_SimpleTemplateId w nns) <|> SimpleTypeSpecifier_TypeName (OptQualified w (Just nns)) . parse)) <|> SimpleTypeSpecifier_TypeName (OptQualified w Nothing) . parse
instance Parse TypeSpecifier where
  autoname_parse = auto1 TypeSpecifier_ClassSpecifier <|> auto1 TypeSpecifier_TrailingTypeSpecifier <|> auto1 TypeSpecifier_EnumSpecifier
instance Parse TrailingTypeSpecifier where
  autoname_parse = auto1 TrailingTypeSpecifier_CvQualifier <|> auto1 TrailingTypeSpecifier_SimpleTypeSpecifier <|> auto1 TrailingTypeSpecifier_TypenameSpecifier <|> auto1 TrailingTypeSpecifier_ElaboratedTypeSpecifier
instance Parse ElaboratedTypeSpecifier where autoname_parse = auto3 ElaboratedTypeSpecifier
instance Parse EnumHead where autoname_parse = auto3 EnumHead
instance Parse EnumBase where autoname_parse = auto2 EnumBase
instance Parse EnumeratorList where autoname_parse = auto1 EnumeratorList
instance Parse EnumeratorDefinition where autoname_parse = auto2 EnumeratorDefinition
instance Parse Enumerator where autoname_parse = auto1 Enumerator
instance Parse EnumKey where autoname_parse = parse >>= \e → EnumKey_Class e . parse <|> EnumKey_Struct e . parse <|> return (EnumKey e)
instance Parse NamespaceDefinition where autoname_parse = auto4 NamespaceDefinition
instance Parse NamespaceBody where autoname_parse = auto1 NamespaceBody
instance Parse LinkageSpecification where autoname_parse = auto3 LinkageSpecification
instance Parse EnumSpecifier where autoname_parse = auto2 EnumSpecifier

-- A.7 Declarators [gram.decl]

instance Parse (RefQualifier, White) where parse = (<?> "ref-qualifier") $ ((,) Rvalue . op AmperAmper) <|> ((,) Lvalue . op Amper)
instance Parse PtrOperator where autoname_parse = auto2 PtrOperator_Ptr <|> PtrOperator_Ref . parse <|> auto4 PtrOperator_Nested
instance Parse PtrAbstractDeclarator where parse = auto2 PtrAbstractDeclarator <|> PtrAbstractDeclarator_NoptrAbstractDeclarator . parse
instance Parse NoptrAbstractDeclarator where parse = liftM2 (foldl $ NoptrAbstractDeclarator . Just) ((NoptrAbstractDeclarator_PtrAbstractDeclarator . parse) <|> NoptrAbstractDeclarator Nothing . parse) (many parse)
instance Parse AbstractDeclarator where autoname_parse = auto1 AbstractDeclarator_PtrAbstractDeclarator
instance Parse InitializerList where autoname_parse = auto1 InitializerList
instance Parse InitializerClause where autoname_parse = auto1 InitializerClause
instance Parse InitDeclaratorList where autoname_parse = auto1 InitDeclaratorList
instance Parse InitDeclarator where
  autoname_parse = do
    declarator ← parse
    if is_pointer_or_reference declarator
      then InitDeclarator declarator . optionMaybe ((<?> "initializer") $ Initializer_Parenthesized . parseParenthesized (Enclosed . ExpressionList . InitializerList . flip Commad [] . parse) <|> auto1 Initializer_BraceOrEqualInitializer)
      else auto1 (InitDeclarator declarator)

instance Parse Declarator where
  autoname_parse = auto1 Declarator_PtrDeclarator <|> auto3 Declarator_TrailingReturnType
instance Parse PtrDeclarator where autoname_parse = liftM2 (flip $ foldl $ flip PtrDeclarator) (reverse . parse) (PtrDeclarator_NoptrDeclarator . parse)

instance Parse NoptrDeclarator where
  parse = liftM2 (foldl f :: NoptrDeclarator -> [Either ParametersAndQualifiers (Squared (Maybe ConstantExpression))] -> NoptrDeclarator) (NoptrDeclarator_Parenthesized . parse <|> NoptrDeclarator_Id . parse) parse
   where f d = either (NoptrDeclarator_WithParams d) (NoptrDeclarator_Squared d)

instance Parse DeclaratorId where autoname_parse = auto2 DeclaratorId_IdExpression
  -- We don't even try to parse a DeclaratorId_Nested, because we can't tell it apart from an IdExpression anyway.

instance Parse TypeId where autoname_parse = typeP id (\x y → TypeId (TypeSpecifierSeq x) $ AbstractDeclarator_PtrAbstractDeclarator . y)

typeP :: (Parse c, Convert b (Maybe (CvQualifier, White)), Convert TypeSpecifier b, ParseSpecifier b) ⇒
  (Maybe PtrAbstractDeclarator → c) → (NeList b → c → a) → Parser Char a
typeP g h = makeTypeExtensions . parseOptions >>= \b → flip fix [] $ \self specs → do
    pspec ← parsePrimarySpec; sspecs ← many parseSecondarySpec
    let (p, q) = neElim $ NeList.reverse $ pspec :| specs
    r ← parse
    return $ h (p :| (q ++ sspecs)) r
   <|> (((: specs) . parseSecondarySpec) >>= self)
   <|> if not b then pzero else do
    let (noncvs, cvs) = partitionMaybe (\x → convert x :: Maybe (CvQualifier, White)) specs
    (x, y) ← apply (map fst cvs) . type_desc
    return $ uncurry h $ second g $ case y of
      Left s → (prefixNeList noncvs (fmap convert $ with_default (s:x)), Nothing)
      Right ad → (prefixNeList noncvs (fmap convert $ with_default x), Just ad)

instance Parse Initializer where autoname_parse = auto1 Initializer_Parenthesized <|> auto1 Initializer_BraceOrEqualInitializer
instance Parse BraceOrEqualInitializer where autoname_parse = auto2 EqualInitializer <|> auto1 BraceInitializer
instance Parse BracedInitList where autoname_parse = auto1 BracedInitList
instance Parse ParametersAndQualifiers where autoname_parse = memoize $ auto4 ParametersAndQualifiers
  {- This memoize prevents an exponential explosion in
      { int b; a(a(a(a(a(a(a(a(a(a(a(a(a(a(a(a(a(a(a(a(a(a(a(a(b+b)))))))))))))))))))))))); }
  -}

instance Parse TrailingReturnType where autoname_parse = auto3 TrailingReturnType

instance Parse ParameterDeclarationClause where
  autoname_parse =
    ParameterDeclarationClause Nothing . Just . parse <|> (do
      l ← parse
      auto2 (ParameterDeclarationClauseWithEllipsis l) <|> ParameterDeclarationClause (Just l) . parse
      ) <|> return (ParameterDeclarationClause Nothing Nothing)

instance Parse ParameterDeclarationList where autoname_parse = auto1 ParameterDeclarationList
instance Parse ParameterDeclaration where autoname_parse = typeP (Right . (AbstractDeclarator_PtrAbstractDeclarator .)) (ParameterDeclaration . DeclSpecifierSeq) >>= auto1

-- Consider the simple-declaration  x y();  . If we just start by parsing a list of decl/type-specifiers, we get [x, y], and consequently we will never succeed in parsing a simple-declaration. For this reason, we distinguish between primary and secondary specifiers, where the former may only occur once in specifier lists. We then parse specifier lists in such a way that we stop when a second primary specifier is encountered (and don't include it in the resulting list). In the example, both x and y are primary specifiers, and so only x becomes part of the list, leaving y to be (correctly) parsed as part of the declarator.
-- There is one context in which this is not sufficient: constructor declarations. In a constructor declaration  T();  , the T is not part of the specifier sequence, but part of the declarator. There, we use a manyTill to stop parsing specifiers as soon as what follows is a valid declarator.
-- We could also use manyTill everywhere and get rid of the primary/secondy distinction, but having the distinction is easier, because it greatly simplifies treatment of other decl-specifier-seq/type-specifier-seq occurrences (because they can just rely on the Parse instances for those respective productions).

class ParseSpecifier s where parsePrimarySpec, parseSecondarySpec :: Parser Char s

instance ParseSpecifier TrailingTypeSpecifier where
  parsePrimarySpec = (<?> "trailing-type-specifier") $ TrailingTypeSpecifier_SimpleTypeSpecifier . primarySimpleTypeSpecifier <|> TrailingTypeSpecifier_TypenameSpecifier . parse <|> TrailingTypeSpecifier_ElaboratedTypeSpecifier . parse
  parseSecondarySpec = (<?> "trailing-type-specifier") $ TrailingTypeSpecifier_CvQualifier . parse <|> TrailingTypeSpecifier_SimpleTypeSpecifier . LengthSpec . parse <|> TrailingTypeSpecifier_SimpleTypeSpecifier . SignSpec . parse <|> TrailingTypeSpecifier_SimpleTypeSpecifier . SimpleTypeSpecifier_BasicType . parse

instance ParseSpecifier TypeSpecifier where
  parsePrimarySpec = (<?> "type-specifier") $ TypeSpecifier_ClassSpecifier . parse <|> TypeSpecifier_TrailingTypeSpecifier . parsePrimarySpec <|> TypeSpecifier_EnumSpecifier . parse
  parseSecondarySpec = (<?> "type-specifier") $ TypeSpecifier_TrailingTypeSpecifier . parseSecondarySpec

instance ParseSpecifier DeclSpecifier where
  parsePrimarySpec = DeclSpecifier_TypeSpecifier . parsePrimarySpec
  parseSecondarySpec = DeclSpecifier_StorageClassSpecifier . parse <|> DeclSpecifier_FunctionSpecifier . parse <|> DeclSpecifier_Friend . parse <|> DeclSpecifier_Typedef . parse <|> DeclSpecifier_ConstExpr . parse <|> DeclSpecifier_AlignmentSpecifier . parse <|> DeclSpecifier_TypeSpecifier . parseSecondarySpec

primarySimpleTypeSpecifier :: Parser Char SimpleTypeSpecifier
primarySimpleTypeSpecifier = (<?> "simple-type-specifier") $ SimpleTypeSpecifier_BasicType . parse
  <|> auto2 SimpleTypeSpecifier_DeclType <|> auto2 SimpleTypeSpecifier_TypeName <|> auto1 LengthSpec <|> auto1 SignSpec <|> auto1 SimpleTypeSpecifier_Auto

instance ParseSpecifier MakeSpecifier where
  parsePrimarySpec = (<?> "make-specifier") $ MakeSpecifier_DeclSpecifier . parsePrimarySpec
  parseSecondarySpec = (<?> "make-specifier") $
    (symbols "non" >> NonFunctionSpecifier . fst . (parse :: Parser Char (FunctionSpecifier, White))) <|>
    (symbols "non" >> NonStorageClassSpecifier . fst . (parse :: Parser Char (StorageClassSpecifier, White))) <|>
    (symbols "non" >> NonCv . fst . (parse :: Parser Char (CvQualifier, White))) <|>
    (symbols "non" >> NonSign . fst . (parse :: Parser Char (Sign, White))) <|>
    (symbols "non" >> NonLength . fst . (parse :: Parser Char (LengthSpec, White))) <|>
    (symbols "implicit" >> return (NonFunctionSpecifier Explicit)) <|>
    MakeSpecifier_DeclSpecifier . parseSecondarySpec

instance Parse TypeSpecifierSeq where
  autoname_parse =
    TypeSpecifierSeq . (liftM2 (:|) parsePrimarySpec (many parseSecondarySpec) <|> liftM2 (:|) parseSecondarySpec lp)
    where lp = liftM2 (:) parsePrimarySpec (many parseSecondarySpec) <|> liftM2 (:) parseSecondarySpec lp <|> return []

instance Parse TrailingTypeSpecifierSeq where autoname_parse = auto1 TrailingTypeSpecifierSeq

instance Parse DeclSpecifier where autoname_parse = parsePrimarySpec <|> parseSecondarySpec

instance Parse FunctionDefinition where
  autoname_parse = do
    (declspecs, (declarator, body)) ← manyTill parse (liftM2 (,) parse parse)
    return $ FunctionDefinition (convert (declspecs :: [DeclSpecifier])) declarator body

instance Parse FunctionBody where autoname_parse = auto2 FunctionBody <|> auto1 FunctionBody_FunctionTryBlock <|> auto3 DefaultedFunctionBody <|> auto3 DeletedFunctionBody

-- A.8 Classes [gram.class]

instance Parse ClassSpecifier where autoname_parse = auto2 ClassSpecifier
instance Parse ClassHead where autoname_parse = auto3 ClassHead
instance Parse ClassHeadKind where parse = auto2 ClassHeadKind_SimpleTemplateId <|> auto2 ClassHeadKind_NestedIdentifier <|> auto1 ClassHeadKind_Identifier
instance Parse MemberSpecification where autoname_parse = auto1 MemberSpecification
instance Parse MemberAccessSpecifier where autoname_parse = auto2 MemberAccessSpecifier
instance Parse MemberDeclaration where
  autoname_parse = do
      (x, (y, z)) ← manyTill parse (liftM2 (,) parse parse)
      return $ MemberDeclaration (convert (x :: [DeclSpecifier])) y z
    <|> auto2 MemberFunctionDefinition <|> auto1 MemberUsingDeclaration <|> auto1 MemberTemplateDeclaration
instance Parse MemberDeclaratorList where autoname_parse = auto1 MemberDeclaratorList
instance Parse MemberDeclarator where autoname_parse = auto3 BitField <|> auto2 MemberDeclarator
instance Parse PureSpecifier where autoname_parse = auto2 PureSpecifier

-- A.9 Derived classes [gram.derived]

instance Parse BaseSpecifierList where autoname_parse = auto1 BaseSpecifierList
instance Parse BaseSpecifier where autoname_parse = auto3 BaseSpecifier
instance Parse BaseClause where autoname_parse = auto2 BaseClause

-- A.10 Special member functions [gram.special]

instance Parse ConversionTypeId where autoname_parse = auto2 ConversionTypeId
instance Parse CtorInitializer where autoname_parse = auto2 CtorInitializer
instance Parse MemInitializerList where autoname_parse = auto1 MemInitializerList
instance Parse MemInitializer where autoname_parse = auto2 MemInitializer
instance Parse MemInitializerId where autoname_parse = auto2 MemInitializerId_ClassName <|> auto1 MemInitializerId_Identifier

-- A.11 Overloading [gram.over]

instance Parse OverloadableOperator where
  parse = (<?> "overloadable operator") $
    auto2 OverloadableOperator_New <|> auto2 OverloadableOperator_Delete <|>
    auto1 OverloadableOperator_Call <|> auto1 OverloadableOperator_Index <|> auto1 OverloadableUnaryOperator <|> auto1 OverloadableAssignmentOperator <|> auto1 OverloadableRelationalOperator <|> auto1 OverloadableMultiplicativeOperator <|> auto1 OverloadableShiftOperator <|> auto1 OverloadableAdditiveOperator <|> auto1 OverloadableEqualityOperator <|> auto1 OverloadableBitXor <|> auto1 OverloadableBitAnd <|> auto1 OverloadableBitOr <|> auto1 OverloadableLogicalAnd <|> auto1 OverloadableLogicalOr <|> auto1 OverloadableComma <|> auto1 OverloadablePmOperator <|> auto1 OverloadableArrowOperator

instance Parse OperatorFunctionId where autoname_parse = auto2 OperatorFunctionId

-- A.12 Templates [gram.temp]

instance Parse TemplateArguments where autoname_parse = memoize $ auto1 TemplateArguments

{- Consider the following code:

  {a<a<a<a<a<a<a<a<a<a<a<a<a<a<a<a<a<a<a<a<a<a<a<a<a; int i; }

At each '<', the parser first tries parsing it as the beginning of a template argument list, before it falls back on treating it as operator<. Hence, without memoization, the above takes exponential time to parse. To solve this, we memoize parsing results. -}

instance Parse TemplateId where autoname_parse = auto2 TemplateId_OperatorFunctionId <|> auto1 TemplateId_SimpleTemplateId
instance Parse TypenameSpecifier where autoname_parse = auto4 TypenameSpecifier
instance Parse SimpleTemplateId where autoname_parse = auto2 SimpleTemplateId
instance Parse TemplateArgumentList where autoname_parse = auto1 TemplateArgumentList
instance Parse TemplateArgument where autoname_parse = auto1 TemplateArgument_TypeId <|> auto1 TemplateArgument_ConstantExpression <|> auto1 TemplateArgument_IdExpression
  -- Todo: There's probably potential for factoring here.
instance Parse TemplateDeclaration where autoname_parse = auto4 TemplateDeclaration
instance Parse TemplateParameterList where autoname_parse = auto1 TemplateParameterList
instance Parse TemplateParameter where autoname_parse = auto1 TemplateParameter_TypeParameter <|> auto1 TemplateParameter_ParameterDeclaration
instance Parse TypeParameter where autoname_parse = auto3 TypeParameter_Class <|> auto5 TypeParameter_Template
instance Parse ExplicitInstantiation where autoname_parse = auto3 ExplicitInstantiation
instance Parse ExplicitSpecialization where autoname_parse = auto3 ExplicitSpecialization

-- A.13 Exception handling [gram.except]

instance Parse ExceptionSpecification where autoname_parse = auto2 ExceptionSpecification
instance Parse TypeIdList where autoname_parse = auto1 TypeIdList
instance Parse TryBlock where autoname_parse = auto3 TryBlock
instance Parse FunctionTryBlock where autoname_parse = auto4 FunctionTryBlock
instance Parse HandlerSeq where autoname_parse = auto1 HandlerSeq
instance Parse Handler where autoname_parse = auto3 Handler
instance Parse ExceptionDeclaration where autoname_parse = auto1 ExceptionDeclaration_Ellipsis <|> auto2 ExceptionDeclaration

-- A.14 Preprocessing directives [gram.cpp]