PageRenderTime 51ms CodeModel.GetById 12ms RepoModel.GetById 1ms app.codeStats 0ms

/src/Cxx/Parse.hs

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