/src/Cxx/Parse.hs

  1{-# LANGUAGE UnicodeSyntax, ScopedTypeVariables, FlexibleInstances, TypeSynonymInstances, MultiParamTypeClasses, FlexibleContexts, OverlappingInstances, GADTs, TypeOperators, TypeFamilies, PatternGuards, DeriveDataTypeable #-}
  2{-# OPTIONS_GHC -O0 #-}
  3
  4{- 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.
  5
  6However, 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:
  7
  8  x*y;
  9
 10we 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).
 11
 12Here are some more typical ambiguous constructs:
 13
 14  int x(y); // If y is a type, this is a function declaration. Otherwise, it's a variable definition.
 15  x<y> z; // If x is a template, this is a variable declaration. Otherwise, it's an expression-statement.
 16  x(y); // If x is a type, this is a variable declaration. Otherwise, it's a function call.
 17  x+(y)(z); // if y is a type, (y)(z) is a cast. Otherwise, it's a function call.
 18
 19We always prefer parsing things as declarations.
 20
 21Note 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.
 22
 23This C++ parser is probably extremely inefficient. Fortunately, geordi only ever runs it on tiny C++ snippets, so we just don't care.
 24
 25-}
 26
 27module Cxx.Parse (Chunk(..), code, charLit, stringLit, makeType, precedence, parseRequest, makeDeclParser, declaratorIdParser, highlight) where
 28
 29import qualified Data.Char as Char
 30import qualified Data.List as List
 31import qualified Data.List.NonEmpty as NeList
 32import qualified Parsers as P
 33import qualified Cxx.Show
 34import Control.Arrow (first, second)
 35import Control.Applicative (Applicative(..))
 36import Control.Monad.Fix (fix)
 37import Control.Monad.Instances ()
 38import Control.Monad (liftM2, liftM3, when)
 39import Data.List ((\\))
 40import Data.List.NonEmpty (NonEmpty(..))
 41import Data.Generics (Data, Typeable, dataTypeOf)
 42import Data.Maybe (mapMaybe)
 43import Data.Function (on)
 44import Data.Foldable (toList)
 45import Util ((<<), (.), Convert(..), isIdChar, Finite(..), Phantom(..), cardinals, partitionMaybe, TriBool(..), (.∨.), NeList, neElim, prefixNeList, neInitLast)
 46import Cxx.Basics
 47import Cxx.Show (pretty_with_precedence, Highlighter)
 48import Cxx.Operations (apply, squared, is_primary_TypeSpecifier, parenthesized, specT, split_all_decls, is_pointer_or_reference)
 49import Prelude hiding ((.))
 50import Prelude.Unicode
 51import Control.Monad.Reader (ReaderT(..))
 52import Parsers ((<?>), (<|>), pzero, spaces, many, optional, choice, sep, many1, symbols, noneOf, lookAhead, symbol, satisfy, optionMaybe, anySymbol, manyTill, many1Till, oneOf, ParserLike, eof, ParseResult(..), getInput, sepBy1, option)
 53import MemoTrie (memo, Trie(..), PairTrie(..), BoolTrie(..))
 54
 55-- Custom parsing monad:
 56
 57data ParseOptions = ParseOptions { makeTypeExtensions :: Bool, pendingCloseAngleBracket :: Bool }
 58
 59instance Trie ParseOptions (PairTrie BoolTrie BoolTrie) where
 60  trie f = trie (\(x, y) → f $ ParseOptions x y)
 61  untrie f (ParseOptions x y) = untrie f (x, y)
 62
 63defaultParseOptions :: ParseOptions
 64defaultParseOptions = ParseOptions { makeTypeExtensions = False, pendingCloseAngleBracket = False }
 65
 66type Parser t = ReaderT ParseOptions (P.Parser t)
 67
 68instance ParserLike (Parser a) a where
 69  anySymbol = ReaderT $ const anySymbol
 70  eof = ReaderT $ const eof
 71  pzero = ReaderT $ const pzero
 72  ReaderT p <?> s = ReaderT $ (<?> s) . p
 73  ReaderT p <|> ReaderT q = ReaderT $ \o → p o <|> q o
 74  symbols = ReaderT . const . symbols
 75  satisfy = ReaderT . const . satisfy
 76  lookAhead (ReaderT p) = ReaderT $ lookAhead . p
 77  try = id
 78
 79parseOptions :: Parser t ParseOptions
 80parseOptions = ReaderT return
 81
 82-- Some combinators:
 83
 84silent :: Parser a b → Parser a b
 85silent (ReaderT f) = ReaderT $ P.silent . f
 86
 87guarded :: (a → Bool) → Parser t a → Parser t a
 88guarded f (ReaderT p) = ReaderT $ P.guarded f . p
 89
 90memoize :: Parser Char a → Parser Char a
 91memoize (ReaderT p) = ReaderT $ \o → P.Parser $ \s → m (o, s)
 92  where m = memo $ \(o, s) → P.run_parser (p o) s
 93    -- 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.
 94
 95notFollowedBy :: Parser t a → Parser t ()
 96notFollowedBy (ReaderT p) = ReaderT $ P.notFollowedBy . p
 97
 98-- Primary module exports
 99
100precedence :: String → Either String String
101precedence s = either (pretty_with_precedence . split_all_decls) (pretty_with_precedence . split_all_decls) .
102  P.parseOrFail p (dropWhile Char.isSpace s) "code"
103  where p = runReaderT (parse << eof) defaultParseOptions :: P.Parser Char (Either Expression [Statement])
104
105highlight :: Highlighter → String → String
106highlight h s =
107  case P.run_parser p (dropWhile Char.isSpace s) of
108    ParseSuccess r _ _ _ → Cxx.Show.show_pretty False h r
109    ParseFailure{} → s
110  where p = runReaderT (parse << eof) defaultParseOptions :: P.Parser Char GeordiRequest
111
112parseRequest :: String → Either String GeordiRequest
113parseRequest s = P.parseOrFail (runReaderT (parse << eof) defaultParseOptions) s "request"
114
115makeType :: String → Either String TypeId
116makeType s = P.parseOrFail (runReaderT (parse << eof) (defaultParseOptions { makeTypeExtensions = True })) (dropWhile Char.isSpace s) "type description"
117
118-- Chunk/Code parsers
119
120textLit :: ParserLike m Char ⇒ Char → m String
121textLit q = (symbol q >>) $ fix $ \h → do
122  s ← many $ noneOf [q, '\\']
123  c ← anySymbol
124  if c == '\\'
125    then do d ← anySymbol; r ← h; return $ s ++ ('\\':d:r)
126    else return s
127
128rawStringLit :: ParserLike m Char ⇒ m Chunk
129rawStringLit = do
130  symbols "R\""
131  x <- fst . (anySymbol `manyTill` symbol '(')
132  y <- fst . (anySymbol `manyTill` P.try (symbols (')' : x) >> symbol '"'))
133  return $ RawStringLiteral x y
134
135-- Parsec's Haskell char/string literal parsers consume whitespace, and save the value rather than the denotation.
136
137charLit, stringLit, digits, plain, parens, curlies, squares, multiComment, singleComment :: ParserLike m Char ⇒ m Chunk
138
139charLit = CharLiteral . textLit '\''
140stringLit = StringLiteral' . textLit '"'
141digits = Plain . (liftM2 (:) (satisfy Char.isDigit) (many (satisfy (\c -> Char.isDigit c || c == '\''))))
142plain = Plain . ((:[]) . oneOf ";\\" <|> toList . many1 punct <|> toList . many1 (satisfy Char.isAlpha))
143  where
144    punct = do
145      c <- satisfy (\c -> not (Char.isAlphaNum c) && not (c `elem` "'\"{([])};\\"))
146      when (c == '/') $ lookAhead (noneOf "*/") >> return ()
147      return c
148parens = Parens . (symbol '(' >> code << symbol ')')
149curlies = Curlies . (symbol '{' >> code << symbol '}')
150squares = Squares . (symbol '[' >> code << symbol ']')
151multiComment = MultiComment . (symbols "/*" >> fst . manyTill anySymbol (symbols "*/"))
152singleComment = SingleComment . (symbols "//" >> many (noneOf "\\"))
153
154code :: ParserLike m Char ⇒ m Code
155code = many $ (<?> "balanced code") $
156  multiComment <|> singleComment <|> charLit <|> parens <|> curlies <|> squares
157  <|> stringLit <|> rawStringLit <|> digits <|> plain
158  -- Uncovers just enough structure for Request.hs to find the split positions in "<< ...; ..." and "{ ... } ..." requests and to implement --resume.
159
160-- Misc parsers.
161
162kwd :: String → Parser Char White
163kwd x = symbols x >> notFollowedBy (satisfy isIdChar) >> parse
164
165makeDeclParser :: P.Parser Char MakeDeclaration
166makeDeclParser = runReaderT parse (defaultParseOptions { makeTypeExtensions = True })
167
168declaratorIdParser :: P.Parser Char DeclaratorId
169declaratorIdParser = runReaderT parse defaultParseOptions
170
171anyOperator :: Parser Char (OperatorTok, White)
172anyOperator = (<?> "operator") $ do
173  o ← parseOptions
174  liftM2 (,) (choice $ if pendingCloseAngleBracket o then pcab else normal) parse
175  where
176    normal = map (\x → symbols (show x) >> return x) $ List.sortBy (flip compare `on` length . show) (all_values :: [OperatorTok])
177    pcab = map (\x → symbols (show x) >> return x) $ List.sortBy (flip compare `on` length . show) $ (all_values :: [OperatorTok]) \\ [CloseTwoAngles, CloseAngle]
178      -- Profiling showed that having these two separate makes a huge difference in space/time efficiency.
179
180op :: OperatorTok → Parser Char White
181op o = (<?> operatorTokName o) $ snd . guarded ((== o) . fst) anyOperator
182
183class Data a ⇒ Parse a where
184  parse :: Parser Char a
185  parse = autoname_parse <?> Cxx.Show.dataType_productionName (dataTypeOf (undefined :: a))
186  autoname_parse :: Parser Char a
187  autoname_parse = parse
188    -- autoname_parse must never be used--it is merely a hook for parse.
189
190instance (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
191instance Parse White where
192  parse = silent $ White . concat . many (
193    (symbols "/*" >> ("/*" ++) . (++ "*/") . fst . manyTill anySymbol (symbols "*/")) <|>
194    (symbols "//" >> ("//" ++) . getInput) <|> symbols " ")
195
196instance Parse a ⇒ Parse [a] where parse = many parse
197instance Parse a ⇒ Parse (Maybe a) where parse = optionMaybe parse
198instance Parse a ⇒ Parse (Enclosed a) where parse = Enclosed . parse
199instance (Parse a, Parse b) ⇒ Parse (a, b) where parse = auto2 (,)
200instance (Parse a, Parse b, Parse c) ⇒ Parse (a, b, c) where parse = auto3 (,,)
201instance (Parse a, Parse b, Parse c, Parse d) ⇒ Parse (a, b, c ,d) where parse = auto4 (,,,)
202instance Parse a ⇒ Parse (Commad a) where parse = liftM2 Commad parse (many (liftM2 (,) parse parse))
203instance (Parse a, Parse b) ⇒ Parse (Either a b) where parse = Left . parse <|> Right . parse
204instance Parse a ⇒ Parse (Angled a) where parse = liftM3 Angled parse (ReaderT $ \o → runReaderT parse (o { pendingCloseAngleBracket = True })) (liftM2 (,) (symbol '>' >> return CloseAngle_) parse)
205instance Parse a ⇒ Parse (Squared a) where parse = liftM3 Squared parse (ReaderT $ \o → runReaderT parse $ o { pendingCloseAngleBracket = False }) parse
206instance Parse a ⇒ Parse (Curlied a) where parse = liftM3 Curlied parse (ReaderT $ \o → runReaderT parse $ o { pendingCloseAngleBracket = False }) parse
207instance Parse a ⇒ Parse (Parenthesized a) where parse = parseParenthesized parse
208instance Parse () where parse = return ()
209instance Parse a ⇒ Parse (NeList a) where parse = many1 parse
210
211parseParenthesized :: Parser Char (Enclosed a) → Parser Char (Parenthesized a)
212parseParenthesized p = liftM3 Parenthesized parse (ReaderT $ \o → runReaderT p $ o { pendingCloseAngleBracket = False }) parse
213
214an :: Parser Char (Maybe White)
215an = silent $ optional $ kwd "an" <|> kwd "a"
216
217pluralP :: String → Parser Char ()
218pluralP s = (>> return ()) $ kwd s <|> kwd (s ++ "s")
219
220delim :: Parser Char ()
221delim = (op CommaTok >> optional (kwd "and") >> return ()) <|> (kwd "and" >> return ())
222
223takingP :: Parser Char ParameterDeclarationClause
224takingP =
225  ((kwd "nothing" <|> (kwd "no" >> kwd "arguments")) >> return (ParameterDeclarationClause Nothing Nothing)) <|> mkParameterDeclarationClause . concat . sepBy1 takingClause (delim >> ((kwd "returning" >> pzero) <|> return ()))
226
227commad :: NeList x → Commad x
228commad l = Commad (NeList.head l) $ (,) (CommaOp, White " ") . NeList.tail l
229
230mkParameterDeclarationClause :: [ParameterDeclaration] → ParameterDeclarationClause
231mkParameterDeclarationClause l =
232  ParameterDeclarationClause (case l of [] → Nothing; h:t → (Just $ ParameterDeclarationList $ commad $ h :| t)) Nothing
233
234instance Parse (CvQualifier, White) where
235  parse = (<?> "cv-qualifier") $ do
236    b ← makeTypeExtensions . parseOptions
237    (if b then (,) Const . kwd "constant" else pzero) <|> (,) Const . kwd "const" <|> (,) Volatile . kwd "volatile"
238
239instance Parse CvQualifierSeq where autoname_parse = auto1 CvQualifierSeq
240
241takingClause :: Parser Char [ParameterDeclaration]
242takingClause = (do
243  IntegerLiteral s ← parse
244  let (n :: Integer) = read s
245  if n > 10 then pzero else replicate (fromInteger n) . parse) <|> (:[]) . (an >> parse)
246
247instance Parse MakeDeclaration where
248  parse = (<?> "type description") $ (an >>) $ (longlong .) $ flip fix [] $ \self specs → do
249    pspec ← parsePrimarySpec
250    sspecs ← many parseSecondarySpec
251    (\x → MakeDeclaration (reverse specs ++ pspec : sspecs) x Indeterminate) . parse
252    <|> (((: specs) . parseSecondarySpec) >>= self)
253    <|> do
254      kwd "pure"
255      let virtSpec = MakeSpecifier_DeclSpecifier $ DeclSpecifier_FunctionSpecifier (Virtual, White " ")
256      do { MakeDeclaration l m _ ← self specs; return $ MakeDeclaration (virtSpec : l) m Definitely } <|> return (MakeDeclaration (virtSpec : specs) Nothing Definitely)
257    <|> do
258      kwd "impure" <|> kwd "nonpure"
259      do { MakeDeclaration l m _ ← self specs; return $ MakeDeclaration l m DefinitelyNot } <|> return (MakeDeclaration specs Nothing DefinitelyNot)
260    <|> do
261    let (noncvs, cvs) = partitionMaybe (convert :: MakeSpecifier → Maybe (CvQualifier, White)) specs
262    (x, y) ← type_desc
263    return $ (\(p, q) → MakeDeclaration p q Indeterminate) $ apply (map fst cvs) $ case y of
264      Left s → (noncvs ++ MakeSpecifier_DeclSpecifier . DeclSpecifier_TypeSpecifier . (x ++ [s]), Nothing)
265      Right ad → (noncvs ++ MakeSpecifier_DeclSpecifier . DeclSpecifier_TypeSpecifier . x, Just ad)
266    <|> (\x → MakeDeclaration specs x Indeterminate) . (if null specs then Just . parse else parse)
267    where
268      longlong m@(MakeDeclaration l x y)
269        | (p, q) ← List.partition (== convert LongSpec) l, length p ≥ 2 = MakeDeclaration (LongLong : q) x y
270        | otherwise = m
271
272literalArrayBound :: IntegerLiteral → ConstantExpression
273literalArrayBound = 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 "")
274
275type_desc :: Parser Char ([TypeSpecifier], Either TypeSpecifier PtrAbstractDeclarator)
276  -- Todo: Document this type
277type_desc = (<?> "type description") $ do
278      o ← (pluralP "pointer" >> return (PtrOperator_Ptr (StarOperator, White "") Nothing))
279        <|> (\k → PtrOperator_Ref (k, White "")) . (((kwd "rvalue" >> return Rvalue) <|> (optional (kwd "lvalue") >> return Lvalue)) << pluralP "reference")
280      (kwd "to" >> an >> second Right . apply o . specdDesc) <|> ((,) [] . Right . flip apply (PtrAbstractDeclarator o Nothing) . (parse :: Parser Char (Maybe PtrAbstractDeclarator)))
281    <|> do
282      pluralP "array"
283      let d = PtrAbstractDeclarator_NoptrAbstractDeclarator . NoptrAbstractDeclarator Nothing . Right . squared
284      do
285        kwd "of"; n ← ((d . Just . literalArrayBound . parse) << spaces) <|> return (d Nothing)
286        second Right . apply n . specdDesc
287       <|> do
288        mad ← parse :: Parser Char (Maybe PtrAbstractDeclarator)
289        return ([], Right $ apply mad (d Nothing))
290    <|> liftM2 (flip apply) (op OpenParen >> specdDesc << op CloseParen) (parse :: Parser Char (Maybe PtrAbstractDeclarator))
291    <|> do
292      pluralP "function"
293      let function_declarator taking = PtrAbstractDeclarator_NoptrAbstractDeclarator $ NoptrAbstractDeclarator Nothing (Left $ ParametersAndQualifiers (parenthesized taking) Nothing Nothing Nothing)
294      do
295        taking ← kwd "taking" >> takingP
296        do
297          second Right . apply (function_declarator taking) . (optional delim >> kwd "returning" >> an >> specdDesc) <|> return ([], Right $ function_declarator taking)
298        <|> do
299        second Right . liftM2 (flip apply) (kwd "returning" >> an >> specdDesc) (function_declarator . ((optional delim >> kwd "taking" >> takingP) <|> return (mkParameterDeclarationClause [])))
300        <|> do
301        (,) [] . Right . flip apply (function_declarator $ mkParameterDeclarationClause []) . (parse :: Parser Char (Maybe PtrAbstractDeclarator))
302  where
303    specdDesc :: Parser Char ([TypeSpecifier], Either TypeSpecifier PtrAbstractDeclarator)
304    specdDesc = (<?> "type description") $ flip fix [] $ \self specs → do
305      morespecs ← liftM2 (:|) parsePrimarySpec (many parseSecondarySpec)
306      let ne = prefixNeList specs morespecs
307      mad ← parse :: Parser Char (Maybe PtrAbstractDeclarator)
308      return $ case mad of
309        Nothing → second Left $ neInitLast ne
310        Just ad → (toList ne, Right ad)
311     <|> do
312      sspec ← parseSecondarySpec
313      self (specs ++ [sspec]) <|> return ([], Left sspec)
314     <|> do
315      let (noncvs, cvs) = partitionMaybe (convert :: TypeSpecifier → Maybe (CvQualifier, White)) specs
316      first (noncvs ++) . apply (map fst cvs) . type_desc
317
318with_default :: [TypeSpecifier] → NeList TypeSpecifier
319with_default [] = return specT
320with_default l@(h:t) = if any is_primary_TypeSpecifier l then h :| t else specT :| l
321
322instance Parse GeordiRequestWithoutWhite where
323  parse = auto3 GeordiRequest_Print <|> auto2 GeordiRequest_Block <|> auto1 GeordiRequest_TU <|> auto2 GeordiRequest_Call
324
325parseAnyMixOf :: Parser t a → Parser t b → Parser t (AnyMixOf a b)
326parseAnyMixOf p q = (p >>= \x → MixAB x . q <|> return (MixA x)) <|> (q >>= \y → MixBA y . p <|> return (MixB y)) <|> return MixNone
327
328instance (Parse a, Parse b) ⇒ Parse (AnyMixOf a b) where parse = parseAnyMixOf parse parse
329
330instance Parse OptQualified where parse = auto2 OptQualified <?> "optional qualification"
331
332auto1 :: (Parse a) ⇒ (a → b) → Parser Char b
333auto1 f = f . parse
334auto2 :: (Parse a, Parse b) ⇒ (a → b → c) → Parser Char c
335auto2 f = auto1 f <*> parse
336auto3 :: (Parse a, Parse b, Parse c) ⇒ (a → b → c → d) → Parser Char d
337auto3 f = auto2 f <*> parse
338auto4 :: (Parse a, Parse b, Parse c, Parse d) ⇒ (a → b → c → d → e) → Parser Char e
339auto4 f = auto3 f <*> parse
340auto5 :: (Parse a, Parse b, Parse c, Parse d, Parse e) ⇒ (a → b → c → d → e → f) → Parser Char f
341auto5 f = auto4 f <*> parse
342auto6 :: (Parse a, Parse b, Parse c, Parse d, Parse e, Parse f) ⇒ (a → b → c → d → e → f → g) → Parser Char g
343auto6 f = auto5 f <*> parse
344
345
346-- Parse instances for all the grammar productions.
347
348-- A.1 Keywords [gram.key]
349
350instance Parse TemplateName where autoname_parse = auto1 TemplateName
351
352-- A.2 Lexical conventions [gram.lex]
353
354instance Parse Identifier where
355  autoname_parse = do
356    b ← makeTypeExtensions . parseOptions
357    let k = keywords ++ if b then make_type_keywords else []
358    liftM2 Identifier (guarded (not . (`elem` k)) $ liftM2 (:) (satisfy $ Char.isAlpha .∨. (== '_')) (many $ satisfy isIdChar)) parse
359
360instance Parse ClassName where autoname_parse = auto1 ClassName_TemplateId <|> auto1 ClassName_Identifier
361instance Parse TypeName where autoname_parse = auto1 TypeName_ClassName
362
363instance Parse FloatingLiteral where
364  autoname_parse = (FloatingLiteral .) $ (>++> optSuffix) $
365    (symbols "." >++> (toList . many1 digit) >++> option "" exponentPart) <|>
366    ((toList . many1 digit) >++> ((symbols "." >++> many digit >++> option "" exponentPart >++> optSuffix) <|> exponentPart))
367    where
368      (>++>) = liftM2 (++)
369      digit = satisfy Char.isDigit
370      optSuffix = option "" $ (:[]) . (symbol 'f' <|> symbol 'l' <|> symbol 'F' <|> symbol 'L')
371      exponentPart = (symbols "e" <|> symbols "E") >++> option "" (symbols "+" <|> symbols "-") >++> (toList . many1 digit)
372instance Parse IntegerLiteral where
373  autoname_parse = (IntegerLiteral .) $ (p <|>) $ do
374    b ← makeTypeExtensions . parseOptions
375    if b then choice $ zipWith (\n s → kwd s >> return (show n)) [0::Int ..] cardinals else pzero
376   where p = liftM2 (:) (satisfy Char.isDigit) (many (satisfy Char.isAlphaNum) << notFollowedBy (satisfy isIdChar))
377instance Parse EncodingPrefix where
378  parse = (symbols "u8" >> return EncodingPrefix_u8) <|> (symbol 'u' >> return EncodingPrefix_u) <|> (symbol 'U' >> return EncodingPrefix_U) <|> (symbol 'L' >> return EncodingPrefix_L)
379instance Parse SingleStringLiteral where parse = liftM2 SingleStringLiteral parse (textLit '"')
380instance Parse StringLiteral where autoname_parse = StringLiteral . many1 (auto2 (,))
381instance Parse CharacterLiteralKind where parse = (symbol 'u' >> return CharacterLiteralKind_u) <|> (symbol 'U' >> return CharacterLiteralKind_U) <|> (symbol 'L' >> return CharacterLiteralKind_L) <|> return CharacterLiteral_Plain
382instance Parse CharacterLiteral where parse = liftM2 CharacterLiteral parse (textLit '\'')
383instance Parse Literal where
384  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"
385
386-- A.3 Basic concepts [gram.basic]
387
388instance Parse TranslationUnit where parse = TranslationUnit . parse
389
390-- A.4 Expressions [gram.expr]
391
392instance Parse PrimaryExpression where
393  autoname_parse =
394    auto1 PrimaryExpression_This <|> auto1 PrimaryExpression_Literal <|>
395    auto1 PrimaryExpression_Expression <|> auto1 PrimaryExpression_IdExpression <|>
396    auto1 PrimaryExpression_LambdaExpression
397instance Parse IdExpression where autoname_parse = auto1 IdExpression
398instance Parse UnqualifiedId where
399  autoname_parse =
400    (parse >>= \w → (UnqualifiedId_OperatorFunctionId . OperatorFunctionId w . parse <|> UnqualifiedId_ConversionFunctionId . ConversionFunctionId w . parse))
401    <|> auto1 UnqualifiedId_TemplateId <|> auto1 UnqualifiedId_Identifier <|> auto2 UnqualifiedId_Destructor
402instance Parse QualifiedId where
403  autoname_parse = (do
404    w ← parse
405    auto3 (NestedUnqualifiedId (Just w)) <|> GlobalIdentifier w . parse <|> GlobalOperatorFunctionId w . parse <|> GlobalTemplateId w . parse
406   ) <|> auto3 (NestedUnqualifiedId Nothing)
407instance Parse NestedNameSpecifier where
408  autoname_parse = liftM2 (foldl (flip ($)))
409    (auto2 NestedNameSpecifier_TypeName)
410    (many $ auto3 (\x y z u → NestedNameSpecifier_SimpleTemplateId u x y z) <|> auto2 (\x y z → NestedNameSpecifier_Identifier z x y))
411      -- We can't distinguish a simple class-name from a namespace-name anyway, so we only try to parse a type-name here.
412instance Parse LambdaExpression where autoname_parse = auto3 LambdaExpression
413instance Parse LambdaIntroducer where autoname_parse = auto1 LambdaIntroducer
414instance Parse LambdaCapture where
415  autoname_parse = (do
416      def ← parse
417      let sofar = LambdaCapture (Just def)
418      m ← optionMaybe (liftM2 (,) parse parse)
419      return $ case m of
420        Just ((c,w), l) → sofar (Just (c, w)) (Just l)
421        Nothing → sofar Nothing Nothing
422    ) <|> auto1 (LambdaCapture Nothing Nothing . Just)
423instance Parse CaptureDefault where autoname_parse = auto1 CaptureDefault
424instance Parse CaptureList where autoname_parse = auto1 CaptureList
425instance Parse Capture where autoname_parse = auto2 Capture_Identifier <|> auto1 Capture_This
426instance Parse LambdaDeclarator where autoname_parse = auto4 LambdaDeclarator
427instance Parse PostfixExpression where
428  autoname_parse = liftM2 (foldl $ flip ($)) basic $ many $ (<?> "postfix operator") $
429      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)
430    where
431     basic = auto3 PostfixExpression_NewStyleCast <|> auto2 PostfixExpression_Conversion <|> auto2 PostfixExpression_TypeId <|> auto1 PostfixExpression_PrimaryExpression
432instance Parse ExpressionList where autoname_parse = auto1 ExpressionList
433instance Parse PseudoDestructorName where
434  autoname_parse = do
435    w ← parse
436    mnns ← parse
437    maybe pzero (auto5 . PseudoDestructorName_InTemplate w) mnns <|>
438      auto2 (PseudoDestructorName (OptQualified w mnns)) <|>
439      auto4 (PseudoDestructorName_InTypeName (OptQualified w mnns))
440simpleBinaryGroup :: (Parse (b, White), Parse a) ⇒ (a1 → (b, White) → a → a1) → (a → a1) → Parser Char a1
441simpleBinaryGroup c l = do
442  (e, f) ← sep parse (parse <?> "binary operator")
443  return $ foldl (\z ((o, w), y) → c z (o, w) y) (l e) f
444simplerBinaryGroup :: (Parse a) ⇒ Parser Char d → (a1 → d → a → a1) → (a → a1) → Parser Char a1
445simplerBinaryGroup p c l = do
446    (e, f) ← sep parse (p <?> "binary operator")
447    return $ foldl (\z (w, y) → c z w y) (l e) f
448instance Parse UnaryExpression where
449  autoname_parse =
450    (parse >>= \w → (UnaryExpression_Sizeof_TypeId w . parse <|> (UnaryExpression_Sizeof_UnaryExpression w . parse))) <|>
451    auto2 UnaryExpression_AlignOf <|> auto2 UnaryExpression <|> UnaryExpression_NewExpression . parse <|> UnaryExpression_DeleteExpression . parse <|> UnaryExpression_PostfixExpression . parse
452instance Parse NewInitializer where autoname_parse = auto1 NewInitializer_ExpressionList <|> auto1 NewInitializer_BracedInitList
453instance Parse NewExpression where autoname_parse = auto5 NewExpression
454instance Parse NewPlacement where autoname_parse = auto1 NewPlacement
455instance Parse NewTypeId where autoname_parse = auto2 NewTypeId
456instance Parse NewDeclarator where autoname_parse = auto2 NewDeclarator_PtrOperator <|> auto1 NewDeclarator_NoptrNewDeclarator
457instance Parse NoptrNewDeclarator where parse = liftM2 NoptrNewDeclarator parse (reverse . parse)
458instance Parse DeleteExpression where autoname_parse = auto4 DeleteExpression
459instance Parse ThrowExpression where autoname_parse = auto2 ThrowExpression
460instance Parse CastExpression where autoname_parse = auto2 CastExpression_Cast <|> CastExpression_UnaryExpression . parse
461instance Parse PmExpression where autoname_parse = simpleBinaryGroup PmExpression PmExpression_CastExpression
462instance Parse MultiplicativeExpression where autoname_parse = simpleBinaryGroup MultiplicativeExpression MultiplicativeExpression_PmExpression
463instance Parse AdditiveExpression where autoname_parse = simpleBinaryGroup AdditiveExpression AdditiveExpression_MultiplicativeExpression
464instance Parse ShiftExpression where autoname_parse = simpleBinaryGroup ShiftExpression ShiftExpression_AdditiveExpression
465instance Parse RelationalExpression where autoname_parse = simpleBinaryGroup RelationalExpression RelationalExpression_ShiftExpression
466instance Parse EqualityExpression where autoname_parse = simpleBinaryGroup EqualityExpression EqualityExpression_RelationalExpression
467instance Parse AndExpression where autoname_parse = simplerBinaryGroup parse AndExpression AndExpression_EqualityExpression
468instance Parse ExclusiveOrExpression where autoname_parse = simplerBinaryGroup parse ExclusiveOrExpression ExclusiveOrExpression_AndExpression
469instance Parse InclusiveOrExpression where autoname_parse = simplerBinaryGroup parse InclusiveOrExpression InclusiveOrExpression_ExclusiveOrExpression
470instance Parse LogicalAndExpression where autoname_parse = simplerBinaryGroup parse LogicalAndExpression LogicalAndExpression_InclusiveOrExpression
471instance Parse LogicalOrExpression where autoname_parse = simplerBinaryGroup parse LogicalOrExpression LogicalOrExpression_LogicalAndExpression
472instance Parse ConditionalExpression where autoname_parse = ConditionalExpression_LogicalOrExpression . parse -- Todo: This is no good, I think.
473instance Parse AssignmentExpression where
474  autoname_parse = (AssignmentExpression_ThrowExpression . parse <|>) $ do
475    e ← parse
476    AssignmentExpression_ConditionalExpression . auto4 (ConditionalExpression e) <|> auto2 (AssignmentExpression e) <|> return (AssignmentExpression_ConditionalExpression $ ConditionalExpression_LogicalOrExpression e)
477instance Parse Expression where autoname_parse = simplerBinaryGroup parse Expression_Comma Expression_AssignmentExpression
478instance Parse ConstantExpression where autoname_parse = auto1 ConstantExpression
479
480-- A.5 Statements [gram.stmt]
481
482instance Parse Statement where
483  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
484
485instance Parse Label where parse = auto1 IdentifierLabel <|> auto2 CaseLabel <|> auto1 DefaultLabel
486instance Parse LabeledStatement where autoname_parse = auto3 LabeledStatement
487instance Parse IterationStatement where autoname_parse = auto3 WhileStatement <|> auto5 DoWhileStatement <|> auto3 ForStatement <|> auto3 RangeForStatement
488instance Parse ForInitStatement where autoname_parse = auto1 ForInitStatement_SimpleDeclaration <|> auto1 ForInitStatement_ExpressionStatement
489instance Parse ForRangeInitializer where autoname_parse = auto1 ForRangeInitializer_Expression <|> auto1 ForRangeInitializer_BracedInitList
490instance Parse ForRangeDeclaration where autoname_parse = uncurry ForRangeDeclaration . first DeclSpecifierSeq . many1Till parse parse
491instance Parse SelectionStatement where autoname_parse = auto4 IfStatement <|> auto3 SwitchStatement
492instance Parse JumpStatement where autoname_parse = auto2 BreakStatement <|> auto2 ContinueStatement <|> auto3 ReturnStatement <|> auto3 GotoStatement
493instance Parse ExpressionStatement where autoname_parse = auto2 ExpressionStatement
494instance Parse Condition where autoname_parse = auto1 Condition_Expression <|> auto3 Condition_Declaration
495instance Parse StatementSeq where autoname_parse = auto1 StatementSeq
496instance Parse CompoundStatement where autoname_parse = auto1 CompoundStatement
497instance Parse DeclarationStatement where autoname_parse = auto1 DeclarationStatement
498
499-- A.6 Declarations [gram.dcl]
500
501instance Parse DeclarationSeq where autoname_parse = auto1 DeclarationSeq
502instance 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
503instance 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
504instance Parse UsingDirective where parse = auto5 UsingDirective
505instance Parse AliasDeclaration where parse = auto5 AliasDeclaration
506instance Parse StaticAssertDeclaration where parse = auto3 StaticAssertDeclaration
507instance Parse NamespaceAliasDefinition where parse = auto6 NamespaceAliasDefinition
508instance Parse NamespaceName where parse = NamespaceName_OriginalNamespaceName . OriginalNamespaceName . parse
509instance Parse AsmDefinition where parse = auto3 AsmDefinition
510  -- Things like AsmDefinition that only occur as specializations of more general productions need no expectation string.
511
512-- 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.
513
514data SpecialNoptrDeclarator = SpecialNoptrDeclarator { specialNoptrDeclarator :: NoptrDeclarator } deriving (Data, Typeable)
515
516instance Parse SpecialNoptrDeclarator where
517  parse = auto2 $ \x y → SpecialNoptrDeclarator $ NoptrDeclarator_WithParams (NoptrDeclarator_Id x) y
518    -- Todo: This is too simplistic. It will fail to parse (obscure) things like "(X)();" and "(X());".
519
520instance Parse SimpleDeclaration where
521  parse = liftM2 (SimpleDeclaration Nothing) (Just . InitDeclaratorList . ((convert . specialNoptrDeclarator) .) . parse) parse <|> do
522    (specs, (decls, semicolon)) ← many1Till parse (liftM2 (,) parse parse)
523    return $ SimpleDeclaration (Just $ DeclSpecifierSeq specs) decls semicolon
524
525instance Parse UsingDeclaration where parse = parse >>= \w → auto5 (UsingDeclaration_Nested w) <|> auto3 (UsingDeclaration_NonNested w)
526instance Parse AlignmentSpecifier where autoname_parse = auto2 AlignmentSpecifier
527instance Parse (BasicType, White) where
528  parse = do
529    b ← makeTypeExtensions . parseOptions
530    if not b
531      then choice $ (\v → (,) v . either kwd op (token v)) . all_values
532      else choice $ map (\(v, k) → (,) v . kwd k) $
533        ((,) Int' . ["ints", "integer", "integers"]) ++
534        ((,) Char' . ["chars", "character", "characters"]) ++
535        ((,) Bool' . ["bools", "boolean", "booleans"]) ++
536        [(Float', "floats"), (Double', "doubles"), (Void, "nothing")] ++
537        mapMaybe (\v → either (Just . (,) v) (const Nothing) (token v)) all_values
538instance Parse SimpleTypeSpecifier where
539  autoname_parse =
540      SimpleTypeSpecifier_Auto . parse <|> SimpleTypeSpecifier_BasicType . parse
541    <|> liftM2 SimpleTypeSpecifier_DeclType parse parse <|> LengthSpec . parse <|> SignSpec . parse
542    <|> do
543      w ← parse
544      (parse >>= \nns → (auto2 (SimpleTypeSpecifier_SimpleTemplateId w nns) <|> SimpleTypeSpecifier_TypeName (OptQualified w (Just nns)) . parse)) <|> SimpleTypeSpecifier_TypeName (OptQualified w Nothing) . parse
545instance Parse TypeSpecifier where
546  autoname_parse = auto1 TypeSpecifier_ClassSpecifier <|> auto1 TypeSpecifier_TrailingTypeSpecifier <|> auto1 TypeSpecifier_EnumSpecifier
547instance Parse TrailingTypeSpecifier where
548  autoname_parse = auto1 TrailingTypeSpecifier_CvQualifier <|> auto1 TrailingTypeSpecifier_SimpleTypeSpecifier <|> auto1 TrailingTypeSpecifier_TypenameSpecifier <|> auto1 TrailingTypeSpecifier_ElaboratedTypeSpecifier
549instance Parse ElaboratedTypeSpecifier where autoname_parse = auto3 ElaboratedTypeSpecifier
550instance Parse EnumHead where autoname_parse = auto3 EnumHead
551instance Parse EnumBase where autoname_parse = auto2 EnumBase
552instance Parse EnumeratorList where autoname_parse = auto1 EnumeratorList
553instance Parse EnumeratorDefinition where autoname_parse = auto2 EnumeratorDefinition
554instance Parse Enumerator where autoname_parse = auto1 Enumerator
555instance Parse EnumKey where autoname_parse = parse >>= \e → EnumKey_Class e . parse <|> EnumKey_Struct e . parse <|> return (EnumKey e)
556instance Parse NamespaceDefinition where autoname_parse = auto4 NamespaceDefinition
557instance Parse NamespaceBody where autoname_parse = auto1 NamespaceBody
558instance Parse LinkageSpecification where autoname_parse = auto3 LinkageSpecification
559instance Parse EnumSpecifier where autoname_parse = auto2 EnumSpecifier
560
561-- A.7 Declarators [gram.decl]
562
563instance Parse (RefQualifier, White) where parse = (<?> "ref-qualifier") $ ((,) Rvalue . op AmperAmper) <|> ((,) Lvalue . op Amper)
564instance Parse PtrOperator where autoname_parse = auto2 PtrOperator_Ptr <|> PtrOperator_Ref . parse <|> auto4 PtrOperator_Nested
565instance Parse PtrAbstractDeclarator where parse = auto2 PtrAbstractDeclarator <|> PtrAbstractDeclarator_NoptrAbstractDeclarator . parse
566instance Parse NoptrAbstractDeclarator where parse = liftM2 (foldl $ NoptrAbstractDeclarator . Just) ((NoptrAbstractDeclarator_PtrAbstractDeclarator . parse) <|> NoptrAbstractDeclarator Nothing . parse) (many parse)
567instance Parse AbstractDeclarator where autoname_parse = auto1 AbstractDeclarator_PtrAbstractDeclarator
568instance Parse InitializerList where autoname_parse = auto1 InitializerList
569instance Parse InitializerClause where autoname_parse = auto1 InitializerClause
570instance Parse InitDeclaratorList where autoname_parse = auto1 InitDeclaratorList
571instance Parse InitDeclarator where
572  autoname_parse = do
573    declarator ← parse
574    if is_pointer_or_reference declarator
575      then InitDeclarator declarator . optionMaybe ((<?> "initializer") $ Initializer_Parenthesized . parseParenthesized (Enclosed . ExpressionList . InitializerList . flip Commad [] . parse) <|> auto1 Initializer_BraceOrEqualInitializer)
576      else auto1 (InitDeclarator declarator)
577
578instance Parse Declarator where
579  autoname_parse = auto1 Declarator_PtrDeclarator <|> auto3 Declarator_TrailingReturnType
580instance Parse PtrDeclarator where autoname_parse = liftM2 (flip $ foldl $ flip PtrDeclarator) (reverse . parse) (PtrDeclarator_NoptrDeclarator . parse)
581
582instance Parse NoptrDeclarator where
583  parse = liftM2 (foldl f :: NoptrDeclarator -> [Either ParametersAndQualifiers (Squared (Maybe ConstantExpression))] -> NoptrDeclarator) (NoptrDeclarator_Parenthesized . parse <|> NoptrDeclarator_Id . parse) parse
584   where f d = either (NoptrDeclarator_WithParams d) (NoptrDeclarator_Squared d)
585
586instance Parse DeclaratorId where autoname_parse = auto2 DeclaratorId_IdExpression
587  -- We don't even try to parse a DeclaratorId_Nested, because we can't tell it apart from an IdExpression anyway.
588
589instance Parse TypeId where autoname_parse = typeP id (\x y → TypeId (TypeSpecifierSeq x) $ AbstractDeclarator_PtrAbstractDeclarator . y)
590
591typeP :: (Parse c, Convert b (Maybe (CvQualifier, White)), Convert TypeSpecifier b, ParseSpecifier b) ⇒
592  (Maybe PtrAbstractDeclarator → c) → (NeList b → c → a) → Parser Char a
593typeP g h = makeTypeExtensions . parseOptions >>= \b → flip fix [] $ \self specs → do
594    pspec ← parsePrimarySpec; sspecs ← many parseSecondarySpec
595    let (p, q) = neElim $ NeList.reverse $ pspec :| specs
596    r ← parse
597    return $ h (p :| (q ++ sspecs)) r
598   <|> (((: specs) . parseSecondarySpec) >>= self)
599   <|> if not b then pzero else do
600    let (noncvs, cvs) = partitionMaybe (\x → convert x :: Maybe (CvQualifier, White)) specs
601    (x, y) ← apply (map fst cvs) . type_desc
602    return $ uncurry h $ second g $ case y of
603      Left s → (prefixNeList noncvs (fmap convert $ with_default (s:x)), Nothing)
604      Right ad → (prefixNeList noncvs (fmap convert $ with_default x), Just ad)
605
606instance Parse Initializer where autoname_parse = auto1 Initializer_Parenthesized <|> auto1 Initializer_BraceOrEqualInitializer
607instance Parse BraceOrEqualInitializer where autoname_parse = auto2 EqualInitializer <|> auto1 BraceInitializer
608instance Parse BracedInitList where autoname_parse = auto1 BracedInitList
609instance Parse ParametersAndQualifiers where autoname_parse = memoize $ auto4 ParametersAndQualifiers
610  {- This memoize prevents an exponential explosion in
611      { 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)))))))))))))))))))))))); }
612  -}
613
614instance Parse TrailingReturnType where autoname_parse = auto3 TrailingReturnType
615
616instance Parse ParameterDeclarationClause where
617  autoname_parse =
618    ParameterDeclarationClause Nothing . Just . parse <|> (do
619      l ← parse
620      auto2 (ParameterDeclarationClauseWithEllipsis l) <|> ParameterDeclarationClause (Just l) . parse
621      ) <|> return (ParameterDeclarationClause Nothing Nothing)
622
623instance Parse ParameterDeclarationList where autoname_parse = auto1 ParameterDeclarationList
624instance Parse ParameterDeclaration where autoname_parse = typeP (Right . (AbstractDeclarator_PtrAbstractDeclarator .)) (ParameterDeclaration . DeclSpecifierSeq) >>= auto1
625
626-- 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.
627-- 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.
628-- 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).
629
630class ParseSpecifier s where parsePrimarySpec, parseSecondarySpec :: Parser Char s
631
632instance ParseSpecifier TrailingTypeSpecifier where
633  parsePrimarySpec = (<?> "trailing-type-specifier") $ TrailingTypeSpecifier_SimpleTypeSpecifier . primarySimpleTypeSpecifier <|> TrailingTypeSpecifier_TypenameSpecifier . parse <|> TrailingTypeSpecifier_ElaboratedTypeSpecifier . parse
634  parseSecondarySpec = (<?> "trailing-type-specifier") $ TrailingTypeSpecifier_CvQualifier . parse <|> TrailingTypeSpecifier_SimpleTypeSpecifier . LengthSpec . parse <|> TrailingTypeSpecifier_SimpleTypeSpecifier . SignSpec . parse <|> TrailingTypeSpecifier_SimpleTypeSpecifier . SimpleTypeSpecifier_BasicType . parse
635
636instance ParseSpecifier TypeSpecifier where
637  parsePrimarySpec = (<?> "type-specifier") $ TypeSpecifier_ClassSpecifier . parse <|> TypeSpecifier_TrailingTypeSpecifier . parsePrimarySpec <|> TypeSpecifier_EnumSpecifier . parse
638  parseSecondarySpec = (<?> "type-specifier") $ TypeSpecifier_TrailingTypeSpecifier . parseSecondarySpec
639
640instance ParseSpecifier DeclSpecifier where
641  parsePrimarySpec = DeclSpecifier_TypeSpecifier . parsePrimarySpec
642  parseSecondarySpec = DeclSpecifier_StorageClassSpecifier . parse <|> DeclSpecifier_FunctionSpecifier . parse <|> DeclSpecifier_Friend . parse <|> DeclSpecifier_Typedef . parse <|> DeclSpecifier_ConstExpr . parse <|> DeclSpecifier_AlignmentSpecifier . parse <|> DeclSpecifier_TypeSpecifier . parseSecondarySpec
643
644primarySimpleTypeSpecifier :: Parser Char SimpleTypeSpecifier
645primarySimpleTypeSpecifier = (<?> "simple-type-specifier") $ SimpleTypeSpecifier_BasicType . parse
646  <|> auto2 SimpleTypeSpecifier_DeclType <|> auto2 SimpleTypeSpecifier_TypeName <|> auto1 LengthSpec <|> auto1 SignSpec <|> auto1 SimpleTypeSpecifier_Auto
647
648instance ParseSpecifier MakeSpecifier where
649  parsePrimarySpec = (<?> "make-specifier") $ MakeSpecifier_DeclSpecifier . parsePrimarySpec
650  parseSecondarySpec = (<?> "make-specifier") $
651    (symbols "non" >> NonFunctionSpecifier . fst . (parse :: Parser Char (FunctionSpecifier, White))) <|>
652    (symbols "non" >> NonStorageClassSpecifier . fst . (parse :: Parser Char (StorageClassSpecifier, White))) <|>
653    (symbols "non" >> NonCv . fst . (parse :: Parser Char (CvQualifier, White))) <|>
654    (symbols "non" >> NonSign . fst . (parse :: Parser Char (Sign, White))) <|>
655    (symbols "non" >> NonLength . fst . (parse :: Parser Char (LengthSpec, White))) <|>
656    (symbols "implicit" >> return (NonFunctionSpecifier Explicit)) <|>
657    MakeSpecifier_DeclSpecifier . parseSecondarySpec
658
659instance Parse TypeSpecifierSeq where
660  autoname_parse =
661    TypeSpecifierSeq . (liftM2 (:|) parsePrimarySpec (many parseSecondarySpec) <|> liftM2 (:|) parseSecondarySpec lp)
662    where lp = liftM2 (:) parsePrimarySpec (many parseSecondarySpec) <|> liftM2 (:) parseSecondarySpec lp <|> return []
663
664instance Parse TrailingTypeSpecifierSeq where autoname_parse = auto1 TrailingTypeSpecifierSeq
665
666instance Parse DeclSpecifier where autoname_parse = parsePrimarySpec <|> parseSecondarySpec
667
668instance Parse FunctionDefinition where
669  autoname_parse = do
670    (declspecs, (declarator, body)) ← manyTill parse (liftM2 (,) parse parse)
671    return $ FunctionDefinition (convert (declspecs :: [DeclSpecifier])) declarator body
672
673instance Parse FunctionBody where autoname_parse = auto2 FunctionBody <|> auto1 FunctionBody_FunctionTryBlock <|> auto3 DefaultedFunctionBody <|> auto3 DeletedFunctionBody
674
675-- A.8 Classes [gram.class]
676
677instance Parse ClassSpecifier where autoname_parse = auto2 ClassSpecifier
678instance Parse ClassHead where autoname_parse = auto3 ClassHead
679instance Parse ClassHeadKind where parse = auto2 ClassHeadKind_SimpleTemplateId <|> auto2 ClassHeadKind_NestedIdentifier <|> auto1 ClassHeadKind_Identifier
680instance Parse MemberSpecification where autoname_parse = auto1 MemberSpecification
681instance Parse MemberAccessSpecifier where autoname_parse = auto2 MemberAccessSpecifier
682instance Parse MemberDeclaration where
683  autoname_parse = do
684      (x, (y, z)) ← manyTill parse (liftM2 (,) parse parse)
685      return $ MemberDeclaration (convert (x :: [DeclSpecifier])) y z
686    <|> auto2 MemberFunctionDefinition <|> auto1 MemberUsingDeclaration <|> auto1 MemberTemplateDeclaration
687instance Parse MemberDeclaratorList where autoname_parse = auto1 MemberDeclaratorList
688instance Parse MemberDeclarator where autoname_parse = auto3 BitField <|> auto2 MemberDeclarator
689instance Parse PureSpecifier where autoname_parse = auto2 PureSpecifier
690
691-- A.9 Derived classes [gram.derived]
692
693instance Parse BaseSpecifierList where autoname_parse = auto1 BaseSpecifierList
694instance Parse BaseSpecifier where autoname_parse = auto3 BaseSpecifier
695instance Parse BaseClause where autoname_parse = auto2 BaseClause
696
697-- A.10 Special member functions [gram.special]
698
699instance Parse ConversionTypeId where autoname_parse = auto2 ConversionTypeId
700instance Parse CtorInitializer where autoname_parse = auto2 CtorInitializer
701instance Parse MemInitializerList where autoname_parse = auto1 MemInitializerList
702instance Parse MemInitializer where autoname_parse = auto2 MemInitializer
703instance Parse MemInitializerId where autoname_parse = auto2 MemInitializerId_ClassName <|> auto1 MemInitializerId_Identifier
704
705-- A.11 Overloading [gram.over]
706
707instance Parse OverloadableOperator where
708  parse = (<?> "overloadable operator") $
709    auto2 OverloadableOperator_New <|> auto2 OverloadableOperator_Delete <|>
710    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
711
712instance Parse OperatorFunctionId where autoname_parse = auto2 OperatorFunctionId
713
714-- A.12 Templates [gram.temp]
715
716instance Parse TemplateArguments where autoname_parse = memoize $ auto1 TemplateArguments
717
718{- Consider the following code:
719
720  {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; }
721
722At 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. -}
723
724instance Parse TemplateId where autoname_parse = auto2 TemplateId_OperatorFunctionId <|> auto1 TemplateId_SimpleTemplateId
725instance Parse TypenameSpecifier where autoname_parse = auto4 TypenameSpecifier
726instance Parse SimpleTemplateId where autoname_parse = auto2 SimpleTemplateId
727instance Parse TemplateArgumentList where autoname_parse = auto1 TemplateArgumentList
728instance Parse TemplateArgument where autoname_parse = auto1 TemplateArgument_TypeId <|> auto1 TemplateArgument_ConstantExpression <|> auto1 TemplateArgument_IdExpression
729  -- Todo: There's probably potential for factoring here.
730instance Parse TemplateDeclaration where autoname_parse = auto4 TemplateDeclaration
731instance Parse TemplateParameterList where autoname_parse = auto1 TemplateParameterList
732instance Parse TemplateParameter where autoname_parse = auto1 TemplateParameter_TypeParameter <|> auto1 TemplateParameter_ParameterDeclaration
733instance Parse TypeParameter where autoname_parse = auto3 TypeParameter_Class <|> auto5 TypeParameter_Template
734instance Parse ExplicitInstantiation where autoname_parse = auto3 ExplicitInstantiation
735instance Parse ExplicitSpecialization where autoname_parse = auto3 ExplicitSpecialization
736
737-- A.13 Exception handling [gram.except]
738
739instance Parse ExceptionSpecification where autoname_parse = auto2 ExceptionSpecification
740instance Parse TypeIdList where autoname_parse = auto1 TypeIdList
741instance Parse TryBlock where autoname_parse = auto3 TryBlock
742instance Parse FunctionTryBlock where autoname_parse = auto4 FunctionTryBlock
743instance Parse HandlerSeq where autoname_parse = auto1 HandlerSeq
744instance Parse Handler where autoname_parse = auto3 Handler
745instance Parse ExceptionDeclaration where autoname_parse = auto1 ExceptionDeclaration_Ellipsis <|> auto2 ExceptionDeclaration
746
747-- A.14 Preprocessing directives [gram.cpp]