language-c-quote-0.13.0.2/0000755000000000000000000000000007346545000013262 5ustar0000000000000000language-c-quote-0.13.0.2/CHANGELOG.md0000644000000000000000000001203007346545000015067 0ustar0000000000000000## [0.13] - 2021-04-29 ### Added - Add quotation support for attributes (Richard Marko) - Add ranges to case labels as a GCC extension (Mark Barbone) ### Fixed - #81 Missing braces cause dangling-else ### Changed - Remove dependency on `symbol` package. ## [0.12.2.1] - 2019-10-04 ### Added - Support for GHC 8.8.1. ## [0.12.2] - 2018-04-02 ### Added - Support for GHC 8.4.1. ### Fixed - #76 C-style comments in cunit declarations ## [0.12.1] - 2017-07-25 ### Fixed - #75 ObjC needs blocks and GCC extension ## [0.12] - 2017-05-05 ### Fixed - Test with GHC 8.2.1. - Bump various bounds. - #71 Bad char literal output - #69 The antiquoter for double and float does not handle infinity correctly ## [0.11.7.3] - 2017-03-10 ### Fixed - Bump other `mainland-pretty` upper bound. ## [0.11.7.2] - 2017-03-05 ### Fixed - Bump `mainland-pretty` upper bound. ## [0.11.7.1] - 2016-12-05 ### Fixed - Bump `HUnit` upper bound. ## [0.11.7] - 2016-10-03 ### Fixed - Fix compatibility with `haskell-src-meta` 0.7.0. ## [0.11.6.3] - 2016-08-30 ### Fixed - Fix alignment of pretty-printed comments. ## [0.11.6.2] - 2016-05-18 ### Fixed - #68 Cannot create block consisting of a single statements antiquote ## [0.11.6.1] - 2016-05-10 ### Added - Bump `syb` upper bound for GHC 8.0.1 compatibility. ## [0.11.6] - 2016-04-12 ### Added - Add support for type qualifier escapes. ## [0.11.5.1] - 2016-04-07 ### Fixed - Try to be -Wparentheses clean. - Fix pretty-pretty of dangling else. - Add missing test modules to tarball. ## [0.11.5] - 2016-03-30 ### Added - Added ToConst and ToExp instances for Int/Word types (Emil Axelsson) - Expression and statement raw string escapes (Kosyrev Serge) - Partial support for C++11 lambda expressions in CUDA code (Michał Wawrzyniec Urbańczyk) ### Fixed - #64 Negated negative constants do not correctly pretty-print. - #59 No obvious way to generate macro code -- not even through $esc:(... :: String) - #51 Objective-C anti-quotations for interface decls broken ## [0.11.4] - 2015-12-22 ### Added - Conditionally use the lightweight haskell-exp-parser instead of haskell-src-meta. ### Fixed - #57 language-c-quote-0.11.3 does not compile with alex 3.1.5 ## [0.11.3] - 2015-10-14 ### Added - `IsString` instances for `Id` and `StringLit` data types. ### Fixed - #55 Comments at the top of a block before a declaration. ## [0.11.2.1] - 2015-10-06 ### Added - Type qualifiers are now allowed before an antiquoted type. ## [0.11.2] - 2015-09-29 ### Added - `qqPat` and `qqExp` are now exposed. ### Changed - Bump upper bound on `syb`. - Providing a starting position is now optional when parsing. ## [0.11.1] - 2015-09-29 ### Added - Automatically-generated `Relocatable` instances added for C abstract syntax types. ### Changed - `Located` instances are also now automatically generated. [0.13]: https://github.com/mainland/language-c-quote/compare/language-c-quote-0.12.2.1...language-c-quote-0.13 [0.12.2.1]: https://github.com/mainland/language-c-quote/compare/language-c-quote-0.12.2...language-c-quote-0.12.2.1 [0.12.2]: https://github.com/mainland/language-c-quote/compare/language-c-quote-0.12.1...language-c-quote-0.12.2 [0.12.1]: https://github.com/mainland/language-c-quote/compare/language-c-quote-0.12...language-c-quote-0.12.1 [0.12]: https://github.com/mainland/language-c-quote/compare/language-c-quote-0.11.7.2...language-c-quote-0.12 [0.11.7.3]: https://github.com/mainland/language-c-quote/compare/language-c-quote-0.11.7.2...language-c-quote-0.11.7.3 [0.11.7.2]: https://github.com/mainland/language-c-quote/compare/language-c-quote-0.11.7.1...language-c-quote-0.11.7.2 [0.11.7.1]: https://github.com/mainland/language-c-quote/compare/language-c-quote-0.11.7...language-c-quote-0.11.7.1 [0.11.7]: https://github.com/mainland/language-c-quote/compare/language-c-quote-0.11.6.3...language-c-quote-0.11.7 [0.11.6.3]: https://github.com/mainland/language-c-quote/compare/language-c-quote-0.11.6.2...language-c-quote-0.11.6.3 [0.11.6.2]: https://github.com/mainland/language-c-quote/compare/language-c-quote-0.11.6.1...language-c-quote-0.11.6.2 [0.11.6.1]: https://github.com/mainland/language-c-quote/compare/language-c-quote-0.11.6...language-c-quote-0.11.6.1 [0.11.6]: https://github.com/mainland/language-c-quote/compare/language-c-quote-0.11.5.1...language-c-quote-0.11.6 [0.11.5.1]: https://github.com/mainland/language-c-quote/compare/language-c-quote-0.11.5...language-c-quote-0.11.5.1 [0.11.5]: https://github.com/mainland/language-c-quote/compare/language-c-quote-0.11.4...language-c-quote-0.11.5 [0.11.4]: https://github.com/mainland/language-c-quote/compare/language-c-quote-0.11.3...language-c-quote-0.11.4 [0.11.3]: https://github.com/mainland/language-c-quote/compare/language-c-quote-0.11.2...language-c-quote-0.11.3 [0.11.2.1]: https://github.com/mainland/language-c-quote/compare/language-c-quote-0.11.2...language-c-quote-0.11.2.1 [0.11.2]: https://github.com/mainland/language-c-quote/compare/language-c-quote-0.11.1...language-c-quote-0.11.2 [0.11.1]: https://github.com/mainland/language-c-quote/compare/language-c-quote-0.11.0.1...language-c-quote-0.11.1 language-c-quote-0.13.0.2/LICENSE0000644000000000000000000001030207346545000014263 0ustar0000000000000000Copyright (c) 2006-2011 The President and Fellows of Harvard College. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: 1. Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. 2. Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. 3. Neither the name of the University nor the names of its contributors may be used to endorse or promote products derived from this software without specific prior written permission. THIS SOFTWARE IS PROVIDED BY THE UNIVERSITY AND CONTRIBUTORS ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE UNIVERSITY OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. Copyright (c) 2011-2013, Geoffrey Mainland All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: 1. Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. 2. Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. Copyright (c) 2013-2024 Drexel University. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: 1. Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. 2. Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. 3. Neither the name of the University nor the names of its contributors may be used to endorse or promote products derived from this software without specific prior written permission. THIS SOFTWARE IS PROVIDED BY THE UNIVERSITY AND CONTRIBUTORS ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE UNIVERSITY OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. language-c-quote-0.13.0.2/Language/0000755000000000000000000000000007346545000015005 5ustar0000000000000000language-c-quote-0.13.0.2/Language/C.hs0000644000000000000000000000052607346545000015526 0ustar0000000000000000-- | -- Module : Language.C -- Copyright : (c) 2009 Harvard University -- License : BSD-style -- Maintainer : mainland@drexel.edu module Language.C ( module Language.C.Parser, module Language.C.Pretty, module Language.C.Syntax ) where import Language.C.Parser import Language.C.Pretty import Language.C.Syntax language-c-quote-0.13.0.2/Language/C/0000755000000000000000000000000007346545000015167 5ustar0000000000000000language-c-quote-0.13.0.2/Language/C/Parser.hs0000644000000000000000000000133007346545000016754 0ustar0000000000000000-- | -- Module : Language.C.Parser -- Copyright : (c) 2006-2010 Harvard University -- License : BSD-style -- Maintainer : mainland@drexel.edu module Language.C.Parser ( module Language.C.Parser.Lexer, module Language.C.Parser.Monad, module Language.C.Parser.Parser, parse ) where import Control.Exception import qualified Data.ByteString.Char8 as B import Data.Loc import Language.C.Parser.Lexer import Language.C.Parser.Parser import Language.C.Parser.Monad import Language.C.Syntax parse :: [Extensions] -> [String] -> P a -> B.ByteString -> Maybe Pos -> Either SomeException a parse exts typnames p bs pos = evalP p (emptyPState exts typnames bs pos) language-c-quote-0.13.0.2/Language/C/Parser/0000755000000000000000000000000007346545000016423 5ustar0000000000000000language-c-quote-0.13.0.2/Language/C/Parser/Lexer.x0000644000000000000000000004547307346545000017710 0ustar0000000000000000-- -*- mode: literate-haskell -*- { {-# OPTIONS -w #-} {-# LANGUAGE CPP #-} -- | -- Module : Language.C.Parser.Lexer -- Copyright : (c) 2006-2011 Harvard University -- (c) 2011-2013 Geoffrey Mainland -- (c) 2013-2015 Drexel University -- License : BSD-style -- Maintainer : mainland@drexel.edu module Language.C.Parser.Lexer ( lexToken ) where #if !MIN_VERSION_base(4,8,0) import Control.Applicative #endif /*!MIN_VERSION_base(4,8,0) */ import Control.Monad (when) import Control.Monad.State import qualified Data.ByteString.Char8 as B import Data.Char (isAlphaNum, isDigit, isOctDigit, isHexDigit, isLower, isSpace, ord, chr, toLower) import Data.List (foldl', intersperse, isPrefixOf) import Data.Loc import qualified Data.Map as Map import Data.Ratio ((%)) import qualified Data.Set as Set import Data.Maybe (fromMaybe) import Text.PrettyPrint.Mainland import qualified Language.C.Syntax as C import Language.C.Parser.Monad import Language.C.Parser.Tokens } $nondigit = [a-z A-Z \_] $digit = [0-9] $nonzerodigit = [1-9] $octalDigit = [0-7] $hexadecimalDigit = [0-9A-Fa-f] @fractionalConstant = $digit* "." $digit+ | $digit+ "." @exponentPart = [eE] [\+\-]? $digit+ @floatingSuffix = [fF] | [lL] @floatingConstant = @fractionalConstant @exponentPart? @floatingSuffix? | $digit+ @exponentPart @floatingSuffix? @decimalConstant = $nonzerodigit $digit* @octalConstant = "0" $octalDigit* @hexadecimalConstant = "0" [xX] $hexadecimalDigit+ @integerSuffix = [uU] [lL]? | [lL] [uU]? | [lL] [lL] [uU]? | [uU] [lL] [lL] $whitechar = [\ \t\n\r\f\v] @ccomment = "//" .* @cppcomment = "/*" ([^\*]|[\r\n]|("*"+([^\*\/]|[\r\n])))* "*"+ "/" c :- <0> { "typename" / { allowAnti } { token Ttypename } "$id:" / { allowAnti } { lexAnti Tanti_id } "$const:" / { allowAnti } { lexAnti Tanti_const } "$int:" / { allowAnti } { lexAnti Tanti_int } "$uint:" / { allowAnti } { lexAnti Tanti_uint } "$lint:" / { allowAnti } { lexAnti Tanti_lint } "$ulint:" / { allowAnti } { lexAnti Tanti_ulint } "$llint:" / { allowAnti } { lexAnti Tanti_llint } "$ullint:" / { allowAnti } { lexAnti Tanti_ullint } "$float:" / { allowAnti } { lexAnti Tanti_float } "$double:" / { allowAnti } { lexAnti Tanti_double } "$ldouble:" / { allowAnti } { lexAnti Tanti_long_double } "$char:" / { allowAnti } { lexAnti Tanti_char } "$string:" / { allowAnti } { lexAnti Tanti_string } "$exp:" / { allowAnti } { lexAnti Tanti_exp } "$func:" / { allowAnti } { lexAnti Tanti_func } "$args:" / { allowAnti } { lexAnti Tanti_args } "$decl:" / { allowAnti } { lexAnti Tanti_decl } "$decls:" / { allowAnti } { lexAnti Tanti_decls } "$sdecl:" / { allowAnti } { lexAnti Tanti_sdecl } "$sdecls:" / { allowAnti } { lexAnti Tanti_sdecls } "$enum:" / { allowAnti } { lexAnti Tanti_enum } "$enums:" / { allowAnti } { lexAnti Tanti_enums } "$esc:" / { allowAnti } { lexAnti Tanti_esc } "$escstm:" / { allowAnti } { lexAnti Tanti_escstm } "$edecl:" / { allowAnti } { lexAnti Tanti_edecl } "$edecls:" / { allowAnti } { lexAnti Tanti_edecls } "$item:" / { allowAnti } { lexAnti Tanti_item } "$items:" / { allowAnti } { lexAnti Tanti_items } "$stm:" / { allowAnti } { lexAnti Tanti_stm } "$stms:" / { allowAnti } { lexAnti Tanti_stms } "$tyqual:" / { allowAnti } { lexAnti Tanti_type_qual } "$tyquals:" / { allowAnti } { lexAnti Tanti_type_quals } "$ty:" / { allowAnti } { lexAnti Tanti_type } "$spec:" / { allowAnti } { lexAnti Tanti_spec } "$param:" / { allowAnti } { lexAnti Tanti_param } "$params:" / { allowAnti } { lexAnti Tanti_params } "$pragma:" / { allowAnti } { lexAnti Tanti_pragma } "$comment:" / { allowAnti } { lexAnti Tanti_comment } "$init:" / { allowAnti } { lexAnti Tanti_init } "$inits:" / { allowAnti } { lexAnti Tanti_inits } "$attr:" / { allowAnti } { lexAnti Tanti_attr } "$attrs:" / { allowAnti } { lexAnti Tanti_attrs } "$" / { allowAnti } { lexAnti Tanti_exp } -- -- Objective-C -- "$ifdecl:" / { allowAnti } { lexAnti Tanti_objc_ifdecl } "$ifdecls:" / { allowAnti } { lexAnti Tanti_objc_ifdecls } "$prop:" / { allowAnti } { lexAnti Tanti_objc_prop } "$props:" / { allowAnti } { lexAnti Tanti_objc_props } "$propattr:" / { allowAnti } { lexAnti Tanti_objc_prop_attr } "$propattrs:" / { allowAnti } { lexAnti Tanti_objc_prop_attrs } "$dictelems:" / { allowAnti } { lexAnti Tanti_objc_dicts } "$methparam:" / { allowAnti } { lexAnti Tanti_objc_param } "$methparams:" / { allowAnti } { lexAnti Tanti_objc_params } "$methproto:" / { allowAnti } { lexAnti Tanti_objc_method_proto } "$methdef:" / { allowAnti } { lexAnti Tanti_objc_method_def } "$methdefs:" / { allowAnti } { lexAnti Tanti_objc_method_defs } "$recv:" / { allowAnti } { lexAnti Tanti_objc_recv } "$kwarg:" / { allowAnti } { lexAnti Tanti_objc_arg } "$kwargs:" / { allowAnti } { lexAnti Tanti_objc_args } } <0> { ^ $whitechar* "#line" $whitechar+ $digit+ $whitechar+ \" [^\"]* \" .* { setLineFromPragma } ^ $whitechar* "#" $whitechar+ $digit+ $whitechar+ \" [^\"]* \" .* { setLineFromPragma } $whitechar* "#" $whitechar* "pragma" $whitechar+ .* { pragmaTok } @ccomment ; @cppcomment ; ^ $whitechar* "#" .* ; $whitechar+ ; "__extension__" ; $nondigit ($nondigit | $digit)* { identifier } @floatingConstant { lexFloat } @decimalConstant @integerSuffix? { lexInteger 0 decimal } @octalConstant @integerSuffix? { lexInteger 1 octal } @hexadecimalConstant @integerSuffix? { lexInteger 2 hexadecimal } \' { lexCharTok } \" { lexStringTok } "(" { token Tlparen } ")" { token Trparen } "[" { token Tlbrack } "]" { token Trbrack } "{" { token Tlbrace } "}" { token Trbrace } "," { token Tcomma } ";" { token Tsemi } ":" { token Tcolon } "?" { token Tquestion } "." { token Tdot } "->" { token Tarrow } "..." { token Tellipses } "+" { token Tplus } "-" { token Tminus } "*" { token Tstar } "/" { token Tdiv } "%" { token Tmod } "~" { token Tnot } "&" { token Tand } "|" { token Tor } "^" { token Txor } "<<" { token Tlsh } ">>" { token Trsh } "++" { token Tinc } "--" { token Tdec } "!" { token Tlnot } "&&" { token Tland } "||" { token Tlor } "==" { token Teq } "!=" { token Tne } "<" { token Tlt } ">" { token Tgt } "<=" { token Tle } ">=" { token Tge } "=" { token Tassign } "+=" { token Tadd_assign } "-=" { token Tsub_assign } "*=" { token Tmul_assign } "/=" { token Tdiv_assign } "%=" { token Tmod_assign } "&=" { token Tand_assign } "|=" { token Tor_assign } "^=" { token Txor_assign } "<<=" { token Tlsh_assign } ">>=" { token Trsh_assign } "{" $whitechar* @ccomment { commentTok Tlbrace } "{" $whitechar* @cppcomment { commentTok Tlbrace } ";" $whitechar* @ccomment { commentTok Tsemi } ";" $whitechar* @cppcomment { commentTok Tsemi } -- -- Objective-C -- "@" / { ifExtension objcExts } { token TObjCat } -- -- CUDA -- "mutable" { token TCUDAmutable } "<<<" / { ifExtension cudaExts } { token TCUDA3lt } ">>>" / { ifExtension cudaExts } { token TCUDA3gt } } { type Action = AlexInput -> AlexInput -> P (L Token) inputString :: AlexInput -> AlexInput -> String inputString beg end = (B.unpack . B.take (alexOff end - alexOff beg)) (alexInput beg) locateTok :: AlexInput -> AlexInput -> Token -> L Token locateTok beg end tok = L (alexLoc beg end) tok token :: Token -> Action token tok beg end = return $ locateTok beg end tok setLineFromPragma :: Action setLineFromPragma beg end = do inp <- getInput setInput inp { alexPos = pos' } lexToken where (_ : l : ws) = words (inputString beg end) line = read l - 1 filename = (takeWhile (/= '\"') . drop 1 . concat . intersperse " ") ws pos' :: Maybe Pos pos' = case alexPos beg of Nothing -> Nothing Just pos -> Just $ Pos filename line 1 (posCoff pos) identifier :: Action identifier beg end = case Map.lookup ident keywordMap of Nothing -> nonKeyword Just (tok, Nothing) -> keyword tok Just (tok, Just i) -> do isKw <- useExts i if isKw then keyword tok else nonKeyword where ident :: String ident = inputString beg end -- NB: Due to the format of the keyword table, the lexer can't currently produce different -- keyword tokens for the same lexeme in dependence on the active language extension. -- We need to distinguish between the 'private' keyword of OpenCL and Objective-C, though, -- to avoid a large number of shift-reduce conflicts. Hence, the ugly special case below. keyword :: Token -> P (L Token) keyword TCLprivate = do isObjC <- useExts objcExts if isObjC then return $ locateTok beg end TObjCprivate else return $ locateTok beg end TCLprivate keyword tok = return $ locateTok beg end tok nonKeyword :: P (L Token) nonKeyword = do typeTest <- isTypedef ident classTest <- isClassdef ident return $ if typeTest then locateTok beg end (Tnamed ident) else if classTest then locateTok beg end (TObjCnamed ident) else locateTok beg end (Tidentifier ident) lexAnti ::(String -> Token) -> Action lexAnti antiTok beg end = do c <- nextChar s <- case c of '(' -> lexExpression 0 "" _ | isIdStartChar c -> lexIdChars [c] | otherwise -> lexerError beg (text "illegal antiquotation") return $ locateTok beg end (antiTok s) where lexIdChars :: String -> P String lexIdChars s = do maybe_c <- maybePeekChar case maybe_c of Just c | isIdChar c -> skipChar >> lexIdChars (c : s) _ -> return (reverse s) lexExpression :: Int -> String -> P String lexExpression depth s = do maybe_c <- maybePeekChar case maybe_c of Nothing -> do end <- getInput parserError (alexLoc beg end) (text "unterminated antiquotation") Just '(' -> skipChar >> lexExpression (depth+1) ('(' : s) Just ')' | depth == 0 -> skipChar >> return (unescape (reverse s)) | otherwise -> skipChar >> lexExpression (depth-1) (')' : s) Just c -> skipChar >> lexExpression depth (c : s) where unescape :: String -> String unescape ('\\':'|':'\\':']':s) = '|' : ']' : unescape s unescape (c:s) = c : unescape s unescape [] = [] isIdStartChar :: Char -> Bool isIdStartChar '_' = True isIdStartChar c = isLower c isIdChar :: Char -> Bool isIdChar '_' = True isIdChar '\'' = True isIdChar c = isAlphaNum c pragmaTok :: Action pragmaTok beg end = return $ locateTok beg end (Tpragma (findPragma (inputString beg end))) where findPragma :: String -> String findPragma s | pragma `isPrefixOf` s = (trim . drop (length pragma)) s where trim = f . f f = reverse . dropWhile isSpace findPragma s = findPragma (tail s) pragma :: String pragma = "pragma" -- XXX: Gross hack. We assume the first character of our input is the textual -- representation of tok, e.g., '{' or ';'. We then scan to the first '/', which -- we assume is the start of the comment. commentTok :: Token -> Action commentTok tok beg end = do pushbackToken $ locateTok commentBeg end (Tcomment (inputString commentBeg end)) return $ locateTok beg tokEnd tok where tokEnd, commentBeg :: AlexInput tokEnd = case alexGetChar beg of Nothing -> error "commentTok: the impossible happened" Just (_, tokEnd) -> tokEnd commentBeg = findCommentStart tokEnd findCommentStart :: AlexInput -> AlexInput findCommentStart inp = case alexGetChar inp of Nothing -> error "commentTok: the impossible happened" Just ('/', inp') -> inp Just (_, inp') -> findCommentStart inp' lexCharTok :: Action lexCharTok beg cur = do c <- nextChar >>= lexChar end <- getInput return $ locateTok beg end (TcharConst (inputString beg end, c)) where lexChar :: Char -> P Char lexChar '\'' = emptyCharacterLiteral beg lexChar '\\' = do c <- lexCharEscape assertNextChar '\'' return c lexChar c = do assertNextChar '\'' return c assertNextChar :: Char -> P () assertNextChar c = do c' <- nextChar when (c' /= c) $ illegalCharacterLiteral cur lexStringTok :: Action lexStringTok beg _ = do s <- lexString "" end <- getInput return $ locateTok beg end (TstringConst (inputString beg end, s)) where lexString :: String -> P String lexString s = do c <- nextChar case c of '"' -> return (reverse s) '\\' -> do c' <- lexCharEscape lexString (c' : s) _ -> lexString (c : s) lexCharEscape :: P Char lexCharEscape = do cur <- getInput c <- nextChar case c of 'a' -> return '\a' 'b' -> return '\b' 'f' -> return '\f' 'n' -> return '\n' 'r' -> return '\r' 't' -> return '\t' 'v' -> return '\v' '\\' -> return '\\' '\'' -> return '\'' '"' -> return '"' '?' -> return '?' 'x' -> chr <$> checkedReadNum isHexDigit 16 hexDigit n | isOctDigit n -> setInput cur >> chr <$> checkedReadNum isOctDigit 8 octDigit c -> return c lexInteger :: Int -> Radix -> Action lexInteger ndrop radix@(_, isRadixDigit, _) beg end = case i of [n] -> return $ locateTok beg end (toToken n) _ -> fail "bad parse for integer" where num :: String num = (takeWhile isRadixDigit . drop ndrop) s suffix :: String suffix = (map toLower . takeWhile (not . isRadixDigit) . reverse) s s :: String s = inputString beg end i :: [Integer] i = do (n, _) <- readInteger radix num return n toToken :: Integer -> Token toToken n = case numElls of 0 -> TintConst (s, isUnsigned, n) 1 -> TlongIntConst (s, isUnsigned, n) 2 -> TlongLongIntConst (s, isUnsigned, n) where numElls :: Int numElls = (length . filter (== 'l')) suffix isUnsigned :: C.Signed isUnsigned = if 'u' `elem` suffix then C.Unsigned else C.Signed lexFloat :: Action lexFloat beg end = case i of [n] -> return $ locateTok beg end (toToken n) _ -> fail "bad parse for float" where s :: String s = inputString beg end prefix :: String prefix = takeWhile (not . isSuffix) s suffix :: String suffix = (map toLower . takeWhile isSuffix . reverse) s isSuffix :: Char -> Bool isSuffix = (`elem` ['l', 'L', 'f', 'F']) i :: [Rational] i = do (n, _) <- readRational s return n toToken :: Rational -> Token toToken n = case suffix of "" -> TdoubleConst (s, fromRational n) "f" -> TfloatConst (s, fromRational n) "l" -> TlongDoubleConst (s, fromRational n) type Radix = (Integer, Char -> Bool, Char -> Int) decDigit :: Char -> Int decDigit c | c >= '0' && c <= '9' = ord c - ord '0' | otherwise = error "error in decimal constant" octDigit :: Char -> Int octDigit c | c >= '0' && c <= '7' = ord c - ord '0' | otherwise = error "error in octal constant" hexDigit :: Char -> Int hexDigit c | c >= 'a' && c <= 'f' = 10 + ord c - ord 'a' | c >= 'A' && c <= 'F' = 10 + ord c - ord 'A' | c >= '0' && c <= '9' = ord c - ord '0' | otherwise = error "error in hexadecimal constant" decimal :: Radix decimal = (10, isDigit, decDigit) octal :: Radix octal = (8, isOctDigit, octDigit) hexadecimal :: Radix hexadecimal = (16, isHexDigit, hexDigit) readInteger :: Radix -> ReadS Integer readInteger (radix, isRadixDigit, charToInt) = go 0 where go :: Integer -> ReadS Integer go x [] = return (x, "") go x (c : cs) | isRadixDigit c = go (x * radix + toInteger (charToInt c)) cs | otherwise = return (x, c : cs) readDecimal :: ReadS Integer readDecimal = readInteger decimal readRational :: ReadS Rational readRational s = do (n, d, t) <- readFix s (x, _) <- readExponent t return ((n % 1) * 10^^(x - toInteger d), t) where readFix :: String -> [(Integer, Int, String)] readFix s = return (read (i ++ f), length f, u) where (i, t) = span isDigit s (f, u) = case t of '.' : u -> span isDigit u _ -> ("", t) readExponent :: ReadS Integer readExponent "" = return (0, "") readExponent (e : s) | e `elem` "eE" = go s | otherwise = return (0, s) where go :: ReadS Integer go ('+' : s) = readDecimal s go ('-' : s) = do (x, t) <- readDecimal s return (-x, t) go s = readDecimal s checkedReadNum :: (Char -> Bool) -> Int -> (Char -> Int) -> P Int checkedReadNum isDigit base conv = do cur <- getInput c <- peekChar when (not $ isDigit c) $ illegalNumericalLiteral cur readNum isDigit base conv readNum :: (Char -> Bool) -> Int -> (Char -> Int) -> P Int readNum isDigit base conv = read 0 where read :: Int -> P Int read n = do c <- peekChar if isDigit c then do let n' = n*base + conv c n' `seq` skipChar >> read n' else return n lexToken :: P (L Token) lexToken = do maybe_tok <- getPushbackToken case maybe_tok of Nothing -> nextToken Just tok -> return tok where nextToken :: P (L Token) nextToken = do beg <- getInput sc <- getLexState st <- get case alexScanUser st beg sc of AlexEOF -> return $ L (alexLoc beg beg) Teof AlexError end -> lexerError end (text rest) where rest :: String rest = B.unpack $ B.take 80 (alexInput end) AlexSkip end _ -> setInput end >> lexToken AlexToken end len t -> setInput end >> t beg end } language-c-quote-0.13.0.2/Language/C/Parser/Monad.hs0000644000000000000000000002715507346545000020027 0ustar0000000000000000-- | -- Module : Language.C.Parser.Monad -- Copyright : (c) 2006-2011 Harvard University -- (c) 2011-2013 Geoffrey Mainland -- License : BSD-style -- Maintainer : mainland@drexel.edu {-# LANGUAGE CPP #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} module Language.C.Parser.Monad ( P, runP, evalP, PState, emptyPState, getInput, setInput, pushLexState, popLexState, getLexState, pushbackToken, getPushbackToken, getCurToken, setCurToken, addTypedef, addClassdef, addVariable, isTypedef, isClassdef, pushScope, popScope, c99Exts, c11Exts, gccExts, blocksExts, cudaExts, openCLExts, objcExts, useExts, antiquotationExts, useC99Exts, useC11Exts, useGccExts, useBlocksExts, useCUDAExts, useOpenCLExts, useObjCExts, LexerException(..), ParserException(..), quoteTok, failAt, lexerError, unexpectedEOF, emptyCharacterLiteral, illegalCharacterLiteral, illegalNumericalLiteral, parserError, unclosed, expected, expectedAt, AlexInput(..), alexGetChar, alexGetByte, alexInputPrevChar, alexLoc, nextChar, peekChar, maybePeekChar, skipChar, AlexPredicate, allowAnti, ifExtension ) where #if !MIN_VERSION_base(4,8,0) import Control.Applicative (Applicative(..)) #endif /* !MIN_VERSION_base(4,8,0) */ import Control.Monad.Exception import Control.Monad.State import Data.Bits import qualified Data.ByteString.Char8 as B import Data.ByteString.Internal (c2w) import Data.List (foldl') import Data.Loc #if !(MIN_VERSION_base(4,9,0)) import Data.Monoid (Monoid(..), (<>)) #endif /* !(MIN_VERSION_base(4,9,0)) */ #if MIN_VERSION_base(4,9,0) && !(MIN_VERSION_base(4,11,0)) import Data.Semigroup (Semigroup(..)) #endif import qualified Data.Set as Set import Data.Typeable (Typeable) import Data.Word import Text.PrettyPrint.Mainland import Text.PrettyPrint.Mainland.Class import Language.C.Parser.Tokens import Language.C.Syntax data PState = PState { input :: !AlexInput , pbToken :: !(Maybe (L Token)) , curToken :: L Token , lexState :: ![Int] , extensions :: !ExtensionsInt , typedefs :: !(Set.Set String) , classdefs :: !(Set.Set String) , scopes :: [(Set.Set String, Set.Set String)] } emptyPState :: [Extensions] -> [String] -> B.ByteString -> Maybe Pos -> PState emptyPState exts typnames buf pos = PState { input = inp , pbToken = Nothing , curToken = error "no token" , lexState = [0] , extensions = foldl' setBit 0 (map fromEnum exts) , typedefs = Set.fromList typnames , classdefs = Set.empty , scopes = [] } where inp :: AlexInput inp = AlexInput { alexPos = pos , alexPrevChar = '\n' , alexInput = buf , alexOff = 0 } newtype P a = P { runP :: PState -> Either SomeException (a, PState) } instance Functor P where fmap f mx = P $ \s -> case runP mx s of Left e -> Left e Right (x, s') -> Right (f x, s') instance Applicative P where pure x = P $ \s -> Right (x, s) mf <*> mx = P $ \s -> case runP mf s of Left e -> Left e Right (f, s') -> runP (fmap f mx) s' instance Monad P where m >>= k = P $ \s -> case runP m s of Left e -> Left e Right (a, s') -> runP (k a) s' return = pure #if MIN_VERSION_base(4,13,0) instance MonadFail P where #endif fail msg = do inp <- getInput throw $ ParserException (alexLoc inp inp) (text msg) instance MonadState PState P where get = P $ \s -> Right (s, s) put s = P $ \_ -> Right ((), s) instance MonadException P where throw e = P $ \_ -> Left (toException e) m `catch` h = P $ \s -> case runP m s of Left e -> case fromException e of Just e' -> runP (h e') s Nothing -> Left e Right (a, s') -> Right (a, s') evalP :: P a -> PState -> Either SomeException a evalP comp st = case runP comp st of Left e -> Left e Right (a, _) -> Right a getInput :: P AlexInput getInput = gets input setInput :: AlexInput -> P () setInput inp = modify $ \s -> s { input = inp } pushLexState :: Int -> P () pushLexState ls = modify $ \s -> s { lexState = ls : lexState s } popLexState :: P Int popLexState = do ls <- getLexState modify $ \s -> s { lexState = tail (lexState s) } return ls getLexState :: P Int getLexState = gets (head . lexState) pushbackToken :: L Token -> P () pushbackToken tok = do maybe_tok <- gets pbToken case maybe_tok of Nothing -> modify $ \s -> s { pbToken = Just tok } Just _ -> fail "More than one token pushed back." getPushbackToken :: P (Maybe (L Token)) getPushbackToken = do tok <- gets pbToken modify $ \s -> s { pbToken = Nothing } return tok getCurToken :: P (L Token) getCurToken = gets curToken setCurToken :: L Token -> P () setCurToken tok = modify $ \s -> s { curToken = tok } addTypedef :: String -> P () addTypedef ident = modify $ \s -> s { typedefs = Set.insert ident (typedefs s) } addClassdef :: String -> P () addClassdef ident = modify $ \s -> s { classdefs = Set.insert ident (classdefs s) } addVariable :: String -> P () addVariable ident = modify $ \s -> s { typedefs = Set.delete ident (typedefs s) , classdefs = Set.delete ident (classdefs s) } isTypedef :: String -> P Bool isTypedef ident = gets $ \s -> Set.member ident (typedefs s) isClassdef :: String -> P Bool isClassdef ident = gets $ \s -> Set.member ident (classdefs s) pushScope :: P () pushScope = modify $ \s -> s { scopes = (typedefs s, classdefs s) : scopes s } popScope :: P () popScope = modify $ \s -> s { scopes = (tail . scopes) s , typedefs = (fst . head . scopes) s , classdefs = (snd . head . scopes) s } antiquotationExts :: ExtensionsInt antiquotationExts = (bit . fromEnum) Antiquotation c99Exts :: ExtensionsInt c99Exts = (bit . fromEnum) C99 c11Exts :: ExtensionsInt c11Exts = (bit . fromEnum) C11 gccExts :: ExtensionsInt gccExts = (bit . fromEnum) Gcc blocksExts :: ExtensionsInt blocksExts = (bit . fromEnum) Blocks cudaExts :: ExtensionsInt cudaExts = (bit . fromEnum) CUDA openCLExts :: ExtensionsInt openCLExts = (bit . fromEnum) OpenCL objcExts :: ExtensionsInt objcExts = (bit . fromEnum) Blocks .|. (bit . fromEnum) ObjC useExts :: ExtensionsInt -> P Bool useExts ext = gets $ \s -> extensions s .&. ext /= 0 useC99Exts :: P Bool useC99Exts = useExts c99Exts useC11Exts :: P Bool useC11Exts = useExts c11Exts useGccExts :: P Bool useGccExts = useExts gccExts useBlocksExts :: P Bool useBlocksExts = useExts blocksExts useCUDAExts :: P Bool useCUDAExts = useExts cudaExts useOpenCLExts :: P Bool useOpenCLExts = useExts openCLExts useObjCExts :: P Bool useObjCExts = useExts objcExts data LexerException = LexerException (Maybe Pos) Doc deriving (Typeable) instance Exception LexerException where instance Show LexerException where show (LexerException pos msg) = pretty 80 $ nest 4 $ ppr pos <> text ":" msg data ParserException = ParserException Loc Doc deriving (Typeable) instance Exception ParserException where instance Show ParserException where show (ParserException loc msg) = pretty 80 $ nest 4 $ ppr loc <> text ":" msg quoteTok :: Doc -> Doc quoteTok = enclose (char '`') (char '\'') failAt :: Loc -> String -> P a failAt loc msg = throw $ ParserException loc (text msg) lexerError :: AlexInput -> Doc -> P a lexerError inp s = throw $ LexerException (alexPos inp) (text "lexer error on" <+> s) unexpectedEOF :: AlexInput -> P a unexpectedEOF inp = lexerError inp (text "unexpected end of file") emptyCharacterLiteral :: AlexInput -> P a emptyCharacterLiteral inp = lexerError inp (text "empty character literal") illegalCharacterLiteral :: AlexInput -> P a illegalCharacterLiteral inp = lexerError inp (text "illegal character literal") illegalNumericalLiteral :: AlexInput -> P a illegalNumericalLiteral inp = lexerError inp (text "illegal numerical literal") parserError :: Loc -> Doc -> P a parserError loc msg = throw $ ParserException loc msg unclosed :: Loc -> String -> P a unclosed loc x = parserError (locEnd loc) (text "unclosed" <+> quoteTok (text x)) expected :: [String] -> Maybe String -> P b expected alts after = do tok <- getCurToken expectedAt tok alts after expectedAt :: L Token -> [String] -> Maybe String -> P b expectedAt tok@(L loc _) alts after = do parserError (locStart loc) (text "expected" <+> pprAlts alts <+> pprGot tok <> pprAfter after) where pprAlts :: [String] -> Doc pprAlts [] = empty pprAlts [s] = text s pprAlts [s1, s2] = text s1 <+> text "or" <+> text s2 pprAlts (s : ss) = text s <> comma <+> pprAlts ss pprGot :: L Token -> Doc pprGot (L _ Teof) = text "but reached end of file" pprGot (L _ t) = text "but got" <+> quoteTok (ppr t) pprAfter :: Maybe String -> Doc pprAfter Nothing = empty pprAfter (Just what) = text " after" <+> text what data AlexInput = AlexInput { alexPos :: !(Maybe Pos) , alexPrevChar :: {-#UNPACK#-} !Char , alexInput :: {-#UNPACK#-} !B.ByteString , alexOff :: {-#UNPACK#-} !Int } alexGetChar :: AlexInput -> Maybe (Char, AlexInput) alexGetChar inp = case B.uncons (alexInput inp) of Nothing -> Nothing Just (c, bs) -> Just (c, inp { alexPos = fmap (\pos -> advancePos pos c) (alexPos inp) , alexPrevChar = c , alexInput = bs , alexOff = alexOff inp + 1 }) alexGetByte :: AlexInput -> Maybe (Word8, AlexInput) alexGetByte inp = case alexGetChar inp of Nothing -> Nothing Just (c, inp') -> Just (c2w c, inp') alexInputPrevChar :: AlexInput -> Char alexInputPrevChar = alexPrevChar alexLoc :: AlexInput -> AlexInput -> Loc alexLoc inp1 inp2 = case (alexPos inp1, alexPos inp2) of (Just pos1, Just pos2) -> Loc pos1 pos2 _ -> NoLoc nextChar :: P Char nextChar = do inp <- getInput case alexGetChar inp of Nothing -> unexpectedEOF inp Just (c, inp') -> setInput inp' >> return c peekChar ::P Char peekChar = do inp <- getInput case B.uncons (alexInput inp) of Nothing -> unexpectedEOF inp Just (c, _) -> return c maybePeekChar :: P (Maybe Char) maybePeekChar = do inp <- getInput case alexGetChar inp of Nothing -> return Nothing Just (c, _) -> return (Just c) skipChar :: P () skipChar = do inp <- getInput case alexGetChar inp of Nothing -> unexpectedEOF inp Just (_, inp') -> setInput inp' -- | The components of an 'AlexPredicate' are the predicate state, input stream -- before the token, length of the token, input stream after the token. type AlexPredicate = PState -> AlexInput -> Int -> AlexInput -> Bool allowAnti :: AlexPredicate allowAnti = ifExtension antiquotationExts ifExtension :: ExtensionsInt -> AlexPredicate ifExtension i s _ _ _ = extensions s .&. i /= 0 language-c-quote-0.13.0.2/Language/C/Parser/Parser.y0000644000000000000000000043656107346545000020070 0ustar0000000000000000-- -*- mode: literate-haskell -*- { {-# OPTIONS -w #-} -- | -- Module : Language.C.Parser.Parser -- Copyright : (c) 2006-2011 Harvard University -- (c) 2011-2012 Geoffrey Mainland -- (c) 2013-2014 Manuel M T Chakravarty -- (c) 2013-2016 Drexel University -- License : BSD-style -- Maintainer : mainland@drexel.edu module Language.C.Parser.Parser where import Control.Monad (forM_, when, unless, liftM) import Control.Monad.Exception import Data.List (intersperse, sort) import Data.Loc import Data.Maybe (fromMaybe, catMaybes) #if !(MIN_VERSION_base(4,9,0)) import Data.Monoid (Monoid(..), (<>)) #endif /* !(MIN_VERSION_base(4,9,0)) */ #if MIN_VERSION_base(4,9,0) && !(MIN_VERSION_base(4,11,0)) import Data.Semigroup (Semigroup(..)) #endif import Text.PrettyPrint.Mainland import Text.PrettyPrint.Mainland.Class import Language.C.Parser.Lexer import Language.C.Parser.Monad import qualified Language.C.Parser.Tokens as T import Language.C.Pretty import Language.C.Syntax import qualified Language.C.Syntax as C } %token CHAR { L _ (T.TcharConst _) } STRING { L _ (T.TstringConst _) } INT { L _ (T.TintConst _) } LONG { L _ (T.TlongIntConst _) } LONG_LONG { L _ (T.TlongLongIntConst _) } FLOAT { L _ (T.TfloatConst _) } DOUBLE { L _ (T.TdoubleConst _) } LONG_DOUBLE { L _ (T.TlongDoubleConst _) } ID { L _ (T.Tidentifier _) } NAMED { L _ (T.Tnamed _) } '(' { L _ T.Tlparen } ')' { L _ T.Trparen } '[' { L _ T.Tlbrack } ']' { L _ T.Trbrack } '{' { L _ T.Tlbrace } '}' { L _ T.Trbrace } ',' { L _ T.Tcomma } ';' { L _ T.Tsemi } ':' { L _ T.Tcolon } '?' { L _ T.Tquestion } '.' { L _ T.Tdot } '->' { L _ T.Tarrow } '...' { L _ T.Tellipses } '+' { L _ T.Tplus } '-' { L _ T.Tminus } '*' { L _ T.Tstar } '/' { L _ T.Tdiv } '%' { L _ T.Tmod } '~' { L _ T.Tnot } '&' { L _ T.Tand } '|' { L _ T.Tor } '^' { L _ T.Txor } '<<' { L _ T.Tlsh } '>>' { L _ T.Trsh } '++' { L _ T.Tinc } '--' { L _ T.Tdec } '!' { L _ T.Tlnot } '&&' { L _ T.Tland } '||' { L _ T.Tlor } '==' { L _ T.Teq } '!=' { L _ T.Tne } '<' { L _ T.Tlt } '>' { L _ T.Tgt } '<=' { L _ T.Tle } '>=' { L _ T.Tge } '=' { L _ T.Tassign } '+=' { L _ T.Tadd_assign } '-=' { L _ T.Tsub_assign } '*=' { L _ T.Tmul_assign } '/=' { L _ T.Tdiv_assign } '%=' { L _ T.Tmod_assign } '<<=' { L _ T.Tlsh_assign } '>>=' { L _ T.Trsh_assign } '&=' { L _ T.Tand_assign } '|=' { L _ T.Tor_assign } '^=' { L _ T.Txor_assign } 'auto' { L _ T.Tauto } 'break' { L _ T.Tbreak } 'case' { L _ T.Tcase } 'char' { L _ T.Tchar } 'const' { L _ T.Tconst } 'continue' { L _ T.Tcontinue } 'default' { L _ T.Tdefault } 'do' { L _ T.Tdo } 'double' { L _ T.Tdouble } 'else' { L _ T.Telse } 'enum' { L _ T.Tenum } 'extern' { L _ T.Textern } 'float' { L _ T.Tfloat } 'for' { L _ T.Tfor } 'goto' { L _ T.Tgoto } 'if' { L _ T.Tif } 'int' { L _ T.Tint } 'long' { L _ T.Tlong } 'register' { L _ T.Tregister } 'return' { L _ T.Treturn } 'short' { L _ T.Tshort } 'signed' { L _ T.Tsigned } 'sizeof' { L _ T.Tsizeof } 'static' { L _ T.Tstatic } 'struct' { L _ T.Tstruct } 'switch' { L _ T.Tswitch } 'typedef' { L _ T.Ttypedef } 'union' { L _ T.Tunion } 'unsigned' { L _ T.Tunsigned } 'void' { L _ T.Tvoid } 'volatile' { L _ T.Tvolatile } 'while' { L _ T.Twhile } '#pragma' { L _ (T.Tpragma _) } '//' { L _ (T.Tcomment _) } -- Used to indicate typedef's the parser hasn't seen first-hand 'typename' { L _ T.Ttypename } ANTI_ID { L _ (T.Tanti_id _) } ANTI_CONST { L _ (T.Tanti_const _) } ANTI_INT { L _ (T.Tanti_int _) } ANTI_UINT { L _ (T.Tanti_uint _) } ANTI_LINT { L _ (T.Tanti_lint _) } ANTI_ULINT { L _ (T.Tanti_ulint _) } ANTI_LLINT { L _ (T.Tanti_llint _) } ANTI_ULLINT { L _ (T.Tanti_ullint _) } ANTI_FLOAT { L _ (T.Tanti_float _) } ANTI_DOUBLE { L _ (T.Tanti_double _) } ANTI_LONG_DOUBLE { L _ (T.Tanti_long_double _) } ANTI_CHAR { L _ (T.Tanti_char _) } ANTI_STRING { L _ (T.Tanti_string _) } ANTI_EXP { L _ (T.Tanti_exp _) } ANTI_FUNC { L _ (T.Tanti_func _) } ANTI_ARGS { L _ (T.Tanti_args _) } ANTI_DECL { L _ (T.Tanti_decl _) } ANTI_DECLS { L _ (T.Tanti_decls _) } ANTI_SDECL { L _ (T.Tanti_sdecl _) } ANTI_SDECLS { L _ (T.Tanti_sdecls _) } ANTI_ENUM { L _ (T.Tanti_enum _) } ANTI_ENUMS { L _ (T.Tanti_enums _) } ANTI_ESC { L _ (T.Tanti_esc _) } ANTI_ESCSTM { L _ (T.Tanti_escstm _) } ANTI_EDECL { L _ (T.Tanti_edecl _) } ANTI_EDECLS { L _ (T.Tanti_edecls _) } ANTI_ITEM { L _ (T.Tanti_item _) } ANTI_ITEMS { L _ (T.Tanti_items _) } ANTI_STM { L _ (T.Tanti_stm _) } ANTI_STMS { L _ (T.Tanti_stms _) } ANTI_SPEC { L _ (T.Tanti_spec _) } ANTI_TYPE_QUAL { L _ (T.Tanti_type_qual _) } ANTI_TYPE_QUALS { L _ (T.Tanti_type_quals _) } ANTI_TYPE { L _ (T.Tanti_type _) } ANTI_PARAM { L _ (T.Tanti_param _) } ANTI_PARAMS { L _ (T.Tanti_params _) } ANTI_PRAGMA { L _ (T.Tanti_pragma _) } ANTI_COMMENT { L _ (T.Tanti_comment _) } ANTI_INIT { L _ (T.Tanti_init _) } ANTI_INITS { L _ (T.Tanti_inits _) } -- -- C99 -- 'inline' { L _ T.Tinline } 'restrict' { L _ T.Trestrict } '_Bool' { L _ T.TBool } '_Complex' { L _ T.TComplex } '_Imaginary' { L _ T.TImaginary } -- -- GCC -- '__asm__' { L _ T.Tasm } '__attribute__' { L _ T.Tattribute } '__extension__' { L _ T.Textension } '__builtin_va_arg' { L _ T.Tbuiltin_va_arg } '__builtin_va_list' { L _ T.Tbuiltin_va_list } '__typeof__' { L _ T.Ttypeof } '__restrict' { L _ T.T__restrict } ANTI_ATTR { L _ (T.Tanti_attr _) } ANTI_ATTRS { L _ (T.Tanti_attrs _) } -- -- Clang blocks -- '__block' { L _ T.T__block } -- -- Objective-C -- OBJCNAMED { L _ (T.TObjCnamed _) } '@' { L _ T.TObjCat } 'autoreleasepool' { L _ T.TObjCautoreleasepool } 'catch' { L _ T.TObjCcatch } 'class' { L _ T.TObjCclass } 'compatibility_alias' { L _ T.TObjCcompatibility_alias } 'dynamic' { L _ T.TObjCdynamic } 'encode' { L _ T.TObjCencode } 'end' { L _ T.TObjCend } 'finally' { L _ T.TObjCfinally } 'interface' { L _ T.TObjCinterface } 'implementation' { L _ T.TObjCimplementation } 'NO' { L _ T.TObjCNO } 'objc_private' { L _ T.TObjCprivate } 'optional' { L _ T.TObjCoptional } 'public' { L _ T.TObjCpublic } 'property' { L _ T.TObjCproperty } 'protected' { L _ T.TObjCprotected } 'package' { L _ T.TObjCpackage } 'protocol' { L _ T.TObjCprotocol } 'required' { L _ T.TObjCrequired } 'selector' { L _ T.TObjCselector } 'synchronized' { L _ T.TObjCsynchronized } 'synthesize' { L _ T.TObjCsynthesize } 'throw' { L _ T.TObjCthrow } 'try' { L _ T.TObjCtry } 'YES' { L _ T.TObjCYES } '__weak' { L _ T.TObjC__weak } '__strong' { L _ T.TObjC__strong } '__unsafe_unretained' { L _ T.TObjC__unsafe_unretained } ANTI_OBJC_IFDECL { L _ (T.Tanti_objc_ifdecl _) } ANTI_OBJC_IFDECLS { L _ (T.Tanti_objc_ifdecls _) } ANTI_OBJC_PROP { L _ (T.Tanti_objc_prop _) } ANTI_OBJC_PROPS { L _ (T.Tanti_objc_props _) } ANTI_OBJC_PROP_ATTR { L _ (T.Tanti_objc_prop_attr _) } ANTI_OBJC_PROP_ATTRS { L _ (T.Tanti_objc_prop_attrs _) } ANTI_OBJC_DICTS { L _ (T.Tanti_objc_dicts _) } ANTI_OBJC_PARAM { L _ (T.Tanti_objc_param _) } ANTI_OBJC_PARAMS { L _ (T.Tanti_objc_params _) } ANTI_OBJC_METHOD_PROTO { L _ (T.Tanti_objc_method_proto _) } ANTI_OBJC_METHOD_DEF { L _ (T.Tanti_objc_method_def _) } ANTI_OBJC_METHOD_DEFS { L _ (T.Tanti_objc_method_defs _) } ANTI_OBJC_RECV { L _ (T.Tanti_objc_recv _) } ANTI_OBJC_ARG { L _ (T.Tanti_objc_arg _) } ANTI_OBJC_ARGS { L _ (T.Tanti_objc_args _) } -- -- CUDA -- 'mutable' { L _ T.TCUDAmutable } '<<<' { L _ T.TCUDA3lt } '>>>' { L _ T.TCUDA3gt } '__device__' { L _ T.TCUDAdevice } '__global__' { L _ T.TCUDAglobal } '__host__' { L _ T.TCUDAhost } '__constant__' { L _ T.TCUDAconstant } '__shared__' { L _ T.TCUDAshared } '__restrict__' { L _ T.TCUDArestrict } '__noinline__' { L _ T.TCUDAnoinline } -- -- OpenCL -- 'private' { L _ T.TCLprivate } '__private' { L _ T.TCLprivate } 'local' { L _ T.TCLlocal } '__local' { L _ T.TCLlocal } 'global' { L _ T.TCLglobal } '__global' { L _ T.TCLglobal } 'constant' { L _ T.TCLconstant } '__constant' { L _ T.TCLconstant } 'read_only' { L _ T.TCLreadonly } '__read_only' { L _ T.TCLreadonly } 'write_only' { L _ T.TCLwriteonly } '__write_only' { L _ T.TCLwriteonly } 'kernel' { L _ T.TCLkernel } '__kernel' { L _ T.TCLkernel } -- Three shift-reduce conflicts: -- (1) Documented conflict in 'objc_protocol_declaration' -- (2) Objective-C exception syntax (would need lookahead of 2 to disambiguate properly) -- (3) The standard dangling else conflict %expect 3 %monad { P } { >>= } { return } %lexer { lexer } { L _ T.Teof } %tokentype { (L T.Token) } %error { happyError } %name parseExp expression %name parseEdecl external_declaration %name parseDecl declaration %name parseStructDecl struct_declaration %name parseEnum enumerator %name parseTypeQuals type_qualifier_list %name parseType type_declaration %name parseParam parameter_declaration %name parseParams parameter_list %name parseInit initializer %name parseStm statement %name parseStms statement_list %name parseBlockItem block_item %name parseBlockItems block_item_list %name parseUnit translation_unit %name parseFunc function_definition %name parseAttr attrib -- -- Objective-C -- %name parseObjCProp objc_property_decl %name parseObjCIfaceDecls objc_interface_decl_list %name parseObjCImplDecls objc_implementation_decl_list %name parseObjCDictElem objc_key_value %name parseObjCPropAttr objc_property_attr %name parseObjCMethodParam objc_method_param %name parseObjCMethodProto objc_method_proto %name parseObjCMethodDef objc_method_definition %name parseObjCMethodRecv objc_receiver %name parseObjCKeywordArg objc_keywordarg %right NAMED OBJCNAMED %% {------------------------------------------------------------------------------ - - Notes on the grammar - - A rule with a '_nla' suffix is a variant of the rule without the suffix such - that it does not contain a leading '__attribute__' specifier. We need these - rules to prevent an ambiguity in old-style function declarations. See the - rule 'declaration_list'. - - A rule with a '_nlt' suffix is a variant of the rule without the suffix such - that it does not contain a leading typedef name. We need these rules to - prevent ambiguity in expressions that re-use a typedef name as an identifier. - ------------------------------------------------------------------------------} {------------------------------------------------------------------------------ - - Identifiers - ------------------------------------------------------------------------------} identifier :: { Id } identifier : ID { Id (getID $1) (srclocOf $1) } | ANTI_ID { AntiId (getANTI_ID $1) (srclocOf $1) } -- Objective-C | 'autoreleasepool' { Id "autoreleasepool" (srclocOf $1) } | 'catch' { Id "catch" (srclocOf $1) } | 'class' { Id "class" (srclocOf $1) } | 'compatibility_alias' { Id "compatibility_alias" (srclocOf $1) } | 'dynamic' { Id "dynamic" (srclocOf $1) } | 'encode' { Id "encode" (srclocOf $1) } | 'end' { Id "end" (srclocOf $1) } | 'finally' { Id "finally" (srclocOf $1) } | 'implementation' { Id "implementation" (srclocOf $1) } | 'interface' { Id "interface" (srclocOf $1) } | 'NO' { Id "NO" (srclocOf $1) } | 'objc_private' { Id "private" (srclocOf $1) } | 'optional' { Id "optional" (srclocOf $1) } | 'public' { Id "public" (srclocOf $1) } | 'property' { Id "property" (srclocOf $1) } | 'protected' { Id "protected" (srclocOf $1) } | 'package' { Id "package" (srclocOf $1) } | 'protocol' { Id "protocol" (srclocOf $1) } | 'required' { Id "required" (srclocOf $1) } | 'selector' { Id "selector" (srclocOf $1) } | 'synchronized' { Id "synchronized" (srclocOf $1) } | 'synthesize' { Id "synthesize" (srclocOf $1) } | 'throw' { Id "throw" (srclocOf $1) } | 'try' { Id "try" (srclocOf $1) } | 'YES' { Id "YES" (srclocOf $1) } identifier_or_typedef :: { Id } identifier_or_typedef : identifier { $1 } | NAMED { Id (getNAMED $1) (srclocOf $1) } -- Objective-C | OBJCNAMED { Id (getOBJCNAMED $1) (srclocOf $1) } {------------------------------------------------------------------------------ - - Constants - ------------------------------------------------------------------------------} constant :: { Const } constant : INT { let (s, sign, n) = getINT $1 in IntConst s sign n (srclocOf $1) } | LONG { let (s, sign, n) = getLONG $1 in LongIntConst s sign n (srclocOf $1) } | LONG_LONG { let (s, sign, n) = getLONG_LONG $1 in LongLongIntConst s sign n (srclocOf $1) } | FLOAT { let (s, n) = getFLOAT $1 in FloatConst s n (srclocOf $1) } | DOUBLE { let (s, n) = getDOUBLE $1 in DoubleConst s n (srclocOf $1) } | LONG_DOUBLE { let (s, n) = getLONG_DOUBLE $1 in LongDoubleConst s n (srclocOf $1) } | CHAR { let (s, c) = getCHAR $1 in CharConst s c (srclocOf $1) } | ANTI_CONST { AntiConst (getANTI_CONST $1) (srclocOf $1) } | ANTI_INT { AntiInt (getANTI_INT $1) (srclocOf $1) } | ANTI_UINT { AntiUInt (getANTI_UINT $1) (srclocOf $1) } | ANTI_LINT { AntiLInt (getANTI_LINT $1) (srclocOf $1) } | ANTI_ULINT { AntiULInt (getANTI_ULINT $1) (srclocOf $1) } | ANTI_LLINT { AntiLLInt (getANTI_LLINT $1) (srclocOf $1) } | ANTI_ULLINT { AntiULLInt (getANTI_ULLINT $1) (srclocOf $1) } | ANTI_FLOAT { AntiFloat (getANTI_FLOAT $1) (srclocOf $1) } | ANTI_DOUBLE { AntiDouble (getANTI_DOUBLE $1) (srclocOf $1) } | ANTI_LONG_DOUBLE { AntiLongDouble (getANTI_LONG_DOUBLE $1) (srclocOf $1) } | ANTI_CHAR { AntiChar (getANTI_CHAR $1) (srclocOf $1) } | ANTI_STRING { AntiString (getANTI_STRING $1) (srclocOf $1) } {------------------------------------------------------------------------------ - - Expressions - ------------------------------------------------------------------------------} lbrace :: { L T.Token } lbrace : '{' { L (locOf $1) T.Tlbrace } | '{' comment { L (locOf $1) T.Tlbrace } semi :: { L T.Token } semi : ';' { L (locOf $1) T.Tsemi } | ';' comment { L (locOf $1) T.Tsemi } string_literal :: { StringLit } string_literal : string_literal_rlist { let { slits = rev $1 ; raw = map (fst . unLoc) slits ; s = (concat . map (snd . unLoc)) slits } in StringLit raw s (srclocOf slits) } string_literal_rlist :: { RevList (L (String, String)) } string_literal_rlist : STRING { rsingleton (L (locOf $1) (getSTRING $1)) } | string_literal_rlist STRING { rcons (L (locOf $2) (getSTRING $2)) $1 } primary_expression :: { Exp } primary_expression : identifier_or_typedef { Var $1 (srclocOf $1) } | constant { Const $1 (srclocOf $1) } | string_literal { Const (mkStringConst $1) (srclocOf $1) } | '(' expression_nlt ')' { $2 } | '(' expression_nlt error {% unclosed ($1 <--> $2) "(" } | '(' compound_statement ')' { StmExpr (mkBlockItems $2) ($1 `srcspan` $3) } | ANTI_ESC { AntiEscExp (getANTI_ESC $1) (srclocOf $1) } | ANTI_EXP { AntiExp (getANTI_EXP $1) (srclocOf $1) } -- Clang blocks | block_literal { $1 } -- Objective-C | objc_message_expression { $1 } | objc_at_expression { $1 } -- CUDA -- C++11 lambda-expression subset | cuda_lambda_expression { $1 } postfix_expression :: { Exp } postfix_expression : primary_expression { $1 } | postfix_expression '[' error {% unclosed (locOf $1) "[" } | postfix_expression '[' expression ']' { Index $1 $3 ($1 `srcspan` $4) } | postfix_expression '(' error {% unclosed (locOf $2) "(" } | postfix_expression '(' ')' { FnCall $1 [] ($1 `srcspan` $3) } | postfix_expression '(' argument_expression_list error {% unclosed ($2 <--> $3) "(" } | postfix_expression '(' argument_expression_list ')' { FnCall $1 $3 ($1 `srcspan` $4) } | postfix_expression '<<<' execution_configuration error {% unclosed ($2 <--> $3) "<<<" } | postfix_expression '<<<' execution_configuration '>>>' '(' ')' { CudaCall $1 $3 [] ($1 `srcspan` $6) } | postfix_expression '<<<' execution_configuration '>>>' '(' argument_expression_list error {% unclosed ($5 <--> $6) "(" } | postfix_expression '<<<' execution_configuration '>>>' '(' argument_expression_list ')' { CudaCall $1 $3 $6 ($1 `srcspan` $7) } | postfix_expression '.' identifier_or_typedef { Member $1 $3 ($1 `srcspan` $3) } | postfix_expression '->' identifier_or_typedef { PtrMember $1 $3 ($1 `srcspan` $3) } | postfix_expression '++' { PostInc $1 ($1 `srcspan` $2) } | postfix_expression '--' { PostDec $1 ($1 `srcspan` $2) } | '(' type_name ')' lbrace initializer_rlist '}' { CompoundLit ($2 :: Type) (rev $5) ($1 `srcspan` $6) } | '(' type_name ')' lbrace initializer_rlist ',' '}' { CompoundLit $2 (rev $5) ($1 `srcspan` $7) } -- GCC | '__builtin_va_arg' '(' assignment_expression ',' type_declaration ')' { BuiltinVaArg $3 $5 ($1 `srcspan` $6) } unary_expression :: { Exp } unary_expression : postfix_expression { $1 } | '++' unary_expression { PreInc $2 ($1 `srcspan` $2) } | '--' unary_expression { PreDec $2 ($1 `srcspan` $2) } | '&' cast_expression { UnOp AddrOf $2 ($1 `srcspan` $2) } | '*' cast_expression { UnOp Deref $2 ($1 `srcspan` $2) } | '+' cast_expression { UnOp Positive $2 ($1 `srcspan` $2) } | '-' cast_expression { UnOp Negate $2 ($1 `srcspan` $2) } | '~' cast_expression { UnOp Not $2 ($1 `srcspan` $2) } | '!' cast_expression { UnOp Lnot $2 ($1 `srcspan` $2) } | 'sizeof' unary_expression { SizeofExp $2 ($1 `srcspan` $2) } | 'sizeof' '(' type_name ')' { SizeofType $3 ($1 `srcspan` $4) } | 'sizeof' '(' type_name error {% unclosed ($2 <--> $3) "(" } cast_expression :: { Exp } cast_expression : unary_expression { $1 } | '(' type_name ')' cast_expression { Cast $2 $4 ($1 `srcspan` $4) } | '(' type_name error {% unclosed ($1 <--> $2) "(" } multiplicative_expression :: { Exp } multiplicative_expression : cast_expression { $1 } | multiplicative_expression '*' cast_expression { BinOp Mul $1 $3 ($1 `srcspan` $3) } | multiplicative_expression '/' cast_expression { BinOp Div $1 $3 ($1 `srcspan` $3) } | multiplicative_expression '%' cast_expression { BinOp Mod $1 $3 ($1 `srcspan` $3) } additive_expression :: { Exp } additive_expression : multiplicative_expression { $1 } | additive_expression '+' multiplicative_expression { BinOp Add $1 $3 ($1 `srcspan` $3) } | additive_expression '-' multiplicative_expression { BinOp Sub $1 $3 ($1 `srcspan` $3) } shift_expression :: { Exp } shift_expression : additive_expression { $1 } | shift_expression '<<' additive_expression { BinOp Lsh $1 $3 ($1 `srcspan` $3) } | shift_expression '>>' additive_expression { BinOp Rsh $1 $3 ($1 `srcspan` $3) } relational_expression :: { Exp } relational_expression : shift_expression { $1 } | relational_expression '<' shift_expression { BinOp Lt $1 $3 ($1 `srcspan` $3) } | relational_expression '>' shift_expression { BinOp Gt $1 $3 ($1 `srcspan` $3) } | relational_expression '<=' shift_expression { BinOp Le $1 $3 ($1 `srcspan` $3) } | relational_expression '>=' shift_expression { BinOp Ge $1 $3 ($1 `srcspan` $3) } equality_expression :: { Exp } equality_expression : relational_expression { $1 } | equality_expression '==' relational_expression { BinOp Eq $1 $3 ($1 `srcspan` $3) } | equality_expression '!=' relational_expression { BinOp Ne $1 $3 ($1 `srcspan` $3) } and_expression :: { Exp } and_expression : equality_expression { $1 } | and_expression '&' equality_expression { BinOp And $1 $3 ($1 `srcspan` $3) } exclusive_or_expression :: { Exp } exclusive_or_expression : and_expression { $1 } | exclusive_or_expression '^' and_expression { BinOp Xor $1 $3 ($1 `srcspan` $3) } inclusive_or_expression :: { Exp } inclusive_or_expression : exclusive_or_expression { $1 } | inclusive_or_expression '|' exclusive_or_expression { BinOp Or $1 $3 ($1 `srcspan` $3) } logical_and_expression :: { Exp } logical_and_expression : inclusive_or_expression { $1 } | logical_and_expression '&&' inclusive_or_expression { BinOp Land $1 $3 ($1 `srcspan` $3) } logical_or_expression :: { Exp } logical_or_expression : logical_and_expression { $1 } | logical_or_expression '||' logical_and_expression { BinOp Lor $1 $3 ($1 `srcspan` $3) } conditional_expression :: { Exp } conditional_expression : logical_or_expression { $1 } | logical_or_expression '?' expression ':' conditional_expression { Cond $1 $3 $5 ($1 `srcspan` $5) } assignment_expression :: { Exp } assignment_expression : conditional_expression { $1 } | unary_expression '=' assignment_expression { Assign $1 JustAssign $3 ($1 `srcspan` $3) } | unary_expression '*=' assignment_expression { Assign $1 MulAssign $3 ($1 `srcspan` $3) } | unary_expression '/=' assignment_expression { Assign $1 DivAssign $3 ($1 `srcspan` $3) } | unary_expression '%=' assignment_expression { Assign $1 ModAssign $3 ($1 `srcspan` $3) } | unary_expression '+=' assignment_expression { Assign $1 AddAssign $3 ($1 `srcspan` $3) } | unary_expression '-=' assignment_expression { Assign $1 SubAssign $3 ($1 `srcspan` $3) } | unary_expression '<<=' assignment_expression { Assign $1 LshAssign $3 ($1 `srcspan` $3) } | unary_expression '>>=' assignment_expression { Assign $1 RshAssign $3 ($1 `srcspan` $3) } | unary_expression '&=' assignment_expression { Assign $1 AndAssign $3 ($1 `srcspan` $3) } | unary_expression '^=' assignment_expression { Assign $1 XorAssign $3 ($1 `srcspan` $3) } | unary_expression '|=' assignment_expression { Assign $1 OrAssign $3 ($1 `srcspan` $3) } expression :: { Exp } expression : assignment_expression { $1 } | expression ',' assignment_expression { Seq $1 $3 ($1 `srcspan` $3) } maybe_expression :: { Maybe Exp } maybe_expression: {- empty -} { Nothing } | expression { Just $1 } constant_expression :: { Exp } constant_expression : conditional_expression { $1 } argument_expression_list :: { [Exp] } argument_expression_list : argument_expression_rlist { rev $1 } argument_expression_rlist :: { RevList Exp } argument_expression_rlist : assignment_expression { rsingleton $1 } | ANTI_ARGS { rsingleton (AntiArgs (getANTI_ARGS $1) (srclocOf $1)) } | argument_expression_rlist ',' assignment_expression { rcons $3 $1} | argument_expression_rlist ',' ANTI_ARGS { rcons (AntiArgs (getANTI_ARGS $3) (srclocOf $3)) $1 } assignment_expression_list :: { [Exp] } assignment_expression_list : assignment_expression_rlist { rev $1 } assignment_expression_rlist :: { RevList Exp } assignment_expression_rlist : assignment_expression { rsingleton $1 } | assignment_expression_rlist ',' assignment_expression { rcons $3 $1 } | assignment_expression_rlist ',' { $1 } {------------------------------------------------------------------------------ - - _nlt expression variants - ------------------------------------------------------------------------------} primary_expression_nlt :: { Exp } primary_expression_nlt : identifier { Var $1 (srclocOf $1) } | constant { Const $1 (srclocOf $1) } | string_literal { Const (mkStringConst $1) (srclocOf $1) } | '(' expression_nlt ')' { $2 } | '(' expression_nlt error {% unclosed ($1 <--> $2) "(" } | '(' compound_statement ')' { StmExpr (mkBlockItems $2) ($1 `srcspan` $3) } | ANTI_ESC { AntiEscExp (getANTI_ESC $1) (srclocOf $1) } | ANTI_EXP { AntiExp (getANTI_EXP $1) (srclocOf $1) } -- Clang blocks | block_literal { $1 } -- Objective-C | objc_message_expression { $1 } | objc_at_expression { $1 } -- CUDA -- C++11 lambda-expression subset | cuda_lambda_expression { $1 } postfix_expression_nlt :: { Exp } postfix_expression_nlt : primary_expression_nlt { $1 } | postfix_expression_nlt '[' error {% unclosed (locOf $1) "[" } | postfix_expression_nlt '[' expression ']' { Index $1 $3 ($1 `srcspan` $4) } | postfix_expression_nlt '(' error {% unclosed (locOf $2) "(" } | postfix_expression_nlt '(' ')' { FnCall $1 [] ($1 `srcspan` $3) } | postfix_expression_nlt '(' argument_expression_nlt_list error {% unclosed ($2 <--> $3) "(" } | postfix_expression_nlt '(' argument_expression_nlt_list ')' { FnCall $1 $3 ($1 `srcspan` $4) } | postfix_expression_nlt '<<<' execution_configuration error {% unclosed ($2 <--> $3) "<<<" } | postfix_expression_nlt '<<<' execution_configuration '>>>' '(' ')' { CudaCall $1 $3 [] ($1 `srcspan` $6) } | postfix_expression_nlt '<<<' execution_configuration '>>>' '(' argument_expression_nlt_list error {% unclosed ($5 <--> $6) "(" } | postfix_expression_nlt '<<<' execution_configuration '>>>' '(' argument_expression_nlt_list ')' { CudaCall $1 $3 $6 ($1 `srcspan` $7) } | postfix_expression_nlt '.' identifier_or_typedef { Member $1 $3 ($1 `srcspan` $3) } | postfix_expression_nlt '->' identifier_or_typedef { PtrMember $1 $3 ($1 `srcspan` $3) } | postfix_expression_nlt '++' { PostInc $1 ($1 `srcspan` $2) } | postfix_expression_nlt '--' { PostDec $1 ($1 `srcspan` $2) } | '(' type_name ')' lbrace initializer_rlist '}' { CompoundLit ($2 :: Type) (rev $5) ($1 `srcspan` $6) } | '(' type_name ')' lbrace initializer_rlist ',' '}' { CompoundLit $2 (rev $5) ($1 `srcspan` $7) } -- GCC | '__builtin_va_arg' '(' assignment_expression_nlt ',' type_declaration ')' { BuiltinVaArg $3 $5 ($1 `srcspan` $6) } unary_expression_nlt :: { Exp } unary_expression_nlt : postfix_expression_nlt { $1 } | '++' unary_expression { PreInc $2 ($1 `srcspan` $2) } | '--' unary_expression { PreDec $2 ($1 `srcspan` $2) } | '&' cast_expression { UnOp AddrOf $2 ($1 `srcspan` $2) } | '*' cast_expression { UnOp Deref $2 ($1 `srcspan` $2) } | '+' cast_expression { UnOp Positive $2 ($1 `srcspan` $2) } | '-' cast_expression { UnOp Negate $2 ($1 `srcspan` $2) } | '~' cast_expression { UnOp Not $2 ($1 `srcspan` $2) } | '!' cast_expression { UnOp Lnot $2 ($1 `srcspan` $2) } | 'sizeof' unary_expression { SizeofExp $2 ($1 `srcspan` $2) } | 'sizeof' '(' type_name ')' { SizeofType $3 ($1 `srcspan` $4) } | 'sizeof' '(' type_name error {% unclosed ($2 <--> $3) "(" } -- This lets us parse expressions like @foo = ...@ where @foo@ is a -- typedef. Quite disgusting... unary_expression_nlt_or_typedef :: { Exp } unary_expression_nlt_or_typedef : unary_expression_nlt { $1 } | NAMED { Var (Id (getNAMED $1) (srclocOf $1)) (srclocOf $1) } cast_expression_nlt :: { Exp } cast_expression_nlt : unary_expression_nlt { $1 } | '(' type_name ')' cast_expression { Cast $2 $4 ($1 `srcspan` $4) } | '(' type_name error {% unclosed ($1 <--> $2) "(" } multiplicative_expression_nlt :: { Exp } multiplicative_expression_nlt : cast_expression_nlt { $1 } | multiplicative_expression_nlt '*' cast_expression { BinOp Mul $1 $3 ($1 `srcspan` $3) } | multiplicative_expression_nlt '/' cast_expression { BinOp Div $1 $3 ($1 `srcspan` $3) } | multiplicative_expression_nlt '%' cast_expression { BinOp Mod $1 $3 ($1 `srcspan` $3) } additive_expression_nlt :: { Exp } additive_expression_nlt : multiplicative_expression_nlt { $1 } | additive_expression_nlt '+' multiplicative_expression { BinOp Add $1 $3 ($1 `srcspan` $3) } | additive_expression_nlt '-' multiplicative_expression { BinOp Sub $1 $3 ($1 `srcspan` $3) } shift_expression_nlt :: { Exp } shift_expression_nlt : additive_expression_nlt { $1 } | shift_expression_nlt '<<' additive_expression { BinOp Lsh $1 $3 ($1 `srcspan` $3) } | shift_expression_nlt '>>' additive_expression { BinOp Rsh $1 $3 ($1 `srcspan` $3) } relational_expression_nlt :: { Exp } relational_expression_nlt : shift_expression_nlt { $1 } | relational_expression_nlt '<' shift_expression { BinOp Lt $1 $3 ($1 `srcspan` $3) } | relational_expression_nlt '>' shift_expression { BinOp Gt $1 $3 ($1 `srcspan` $3) } | relational_expression_nlt '<=' shift_expression { BinOp Le $1 $3 ($1 `srcspan` $3) } | relational_expression_nlt '>=' shift_expression { BinOp Ge $1 $3 ($1 `srcspan` $3) } equality_expression_nlt :: { Exp } equality_expression_nlt : relational_expression_nlt { $1 } | equality_expression_nlt '==' relational_expression { BinOp Eq $1 $3 ($1 `srcspan` $3) } | equality_expression_nlt '!=' relational_expression { BinOp Ne $1 $3 ($1 `srcspan` $3) } and_expression_nlt :: { Exp } and_expression_nlt : equality_expression_nlt { $1 } | and_expression_nlt '&' equality_expression { BinOp And $1 $3 ($1 `srcspan` $3) } exclusive_or_expression_nlt :: { Exp } exclusive_or_expression_nlt : and_expression_nlt { $1 } | exclusive_or_expression_nlt '^' and_expression_nlt { BinOp Xor $1 $3 ($1 `srcspan` $3) } inclusive_or_expression_nlt :: { Exp } inclusive_or_expression_nlt : exclusive_or_expression_nlt { $1 } | inclusive_or_expression_nlt '|' exclusive_or_expression { BinOp Or $1 $3 ($1 `srcspan` $3) } logical_and_expression_nlt :: { Exp } logical_and_expression_nlt : inclusive_or_expression_nlt { $1 } | logical_and_expression_nlt '&&' inclusive_or_expression { BinOp Land $1 $3 ($1 `srcspan` $3) } logical_or_expression_nlt :: { Exp } logical_or_expression_nlt : logical_and_expression_nlt { $1 } | logical_or_expression_nlt '||' logical_and_expression { BinOp Lor $1 $3 ($1 `srcspan` $3) } conditional_expression_nlt :: { Exp } conditional_expression_nlt : logical_or_expression_nlt { $1 } | logical_or_expression_nlt '?' expression ':' conditional_expression { Cond $1 $3 $5 ($1 `srcspan` $5) } assignment_expression_nlt :: { Exp } assignment_expression_nlt : conditional_expression_nlt { $1 } | unary_expression_nlt_or_typedef '=' assignment_expression { Assign $1 JustAssign $3 ($1 `srcspan` $3) } | unary_expression_nlt_or_typedef '*=' assignment_expression { Assign $1 MulAssign $3 ($1 `srcspan` $3) } | unary_expression_nlt_or_typedef '/=' assignment_expression { Assign $1 DivAssign $3 ($1 `srcspan` $3) } | unary_expression_nlt_or_typedef '%=' assignment_expression { Assign $1 ModAssign $3 ($1 `srcspan` $3) } | unary_expression_nlt_or_typedef '+=' assignment_expression { Assign $1 AddAssign $3 ($1 `srcspan` $3) } | unary_expression_nlt_or_typedef '-=' assignment_expression { Assign $1 SubAssign $3 ($1 `srcspan` $3) } | unary_expression_nlt_or_typedef '<<=' assignment_expression { Assign $1 LshAssign $3 ($1 `srcspan` $3) } | unary_expression_nlt_or_typedef '>>=' assignment_expression { Assign $1 RshAssign $3 ($1 `srcspan` $3) } | unary_expression_nlt_or_typedef '&=' assignment_expression { Assign $1 AndAssign $3 ($1 `srcspan` $3) } | unary_expression_nlt_or_typedef '^=' assignment_expression { Assign $1 XorAssign $3 ($1 `srcspan` $3) } | unary_expression_nlt_or_typedef '|=' assignment_expression { Assign $1 OrAssign $3 ($1 `srcspan` $3) } expression_nlt :: { Exp } expression_nlt : assignment_expression_nlt { $1 } | expression_nlt ',' assignment_expression { Seq $1 $3 ($1 `srcspan` $3) } maybe_expression_nlt :: { Maybe Exp } maybe_expression_nlt: {- empty -} { Nothing } | expression_nlt { Just $1 } argument_expression_nlt_list :: { [Exp] } argument_expression_nlt_list : assignment_expression_nlt { [$1] } | ANTI_ARGS { [AntiArgs (getANTI_ARGS $1) (srclocOf $1)] } | assignment_expression_nlt ',' argument_expression_rlist { $1 : rev $3 } | ANTI_ARGS ',' argument_expression_rlist { AntiArgs (getANTI_ARGS $1) (srclocOf $1) : rev $3 } {------------------------------------------------------------------------------ - - Declarations - ------------------------------------------------------------------------------} {- -- XXX: This is an awful hack to get around problems with the interaction -- between lexer feedback and the one-token lookahead that happy does. If we -- encounter a typedef and the next token is the newly typedef'd type, we get an -- error if we include the terminal semicolon directly in the productions for -- declaration. By splitting the semicolon out, the lookahead token is -- guaranteed not to be a typedef use :) -} declaration :: { InitGroup } declaration : declaration_ ';' { $1 } declaration_nla :: { InitGroup } declaration_nla : declaration_nla_ ';' { $1 } declaration_ :: { InitGroup } declaration_ : declaration_specifiers {% do{ let (dspec, decl) = $1 ; checkInitGroup dspec decl [] [] } } | declaration_specifiers init_declarator_rlist {% do{ let (dspec, decl) = $1 ; let inits = rev $2 ; checkInitGroup dspec decl [] (rev $2) } } | declaration_specifiers error {% do{ let (_, decl) = $1 ; expected ["';'"] (Just "declaration") } } | ANTI_DECL { AntiDecl (getANTI_DECL $1) (srclocOf $1) } declaration_nla_ :: { InitGroup } declaration_nla_ : declaration_specifiers_nla {% do{ let (dspec, decl) = $1 ; checkInitGroup dspec decl [] [] } } | declaration_specifiers_nla init_declarator_rlist {% do{ let (dspec, decl) = $1 ; let inits = rev $2 ; checkInitGroup dspec decl [] (rev $2) } } | declaration_specifiers_nla error {% do{ let (_, decl) = $1 ; expected ["';'"] (Just "declaration") } } | ANTI_DECL { AntiDecl (getANTI_DECL $1) (srclocOf $1) } declaration_specifiers :: { (DeclSpec, Decl) } declaration_specifiers : ANTI_TYPE { let { v = getANTI_TYPE $1 ; l = srclocOf $1 } in (AntiTypeDeclSpec [] [] v l, AntiTypeDecl v l) } | storage_qualifier_specifiers ANTI_TYPE { let { storage = mkStorage $1 ; typeQuals = mkTypeQuals $1 ; v = getANTI_TYPE $2 ; l = $1 `srcspan` $2 } in (AntiTypeDeclSpec storage typeQuals v l, AntiTypeDecl v l) } | nontypedef_declaration_specifiers { $1 } | typedef_declaration_specifiers { $1 } declaration_specifiers_nla :: { (DeclSpec, Decl) } declaration_specifiers_nla : ANTI_TYPE { let { v = getANTI_TYPE $1 ; l = srclocOf $1 } in (AntiTypeDeclSpec [] [] v l, AntiTypeDecl v l) } | storage_qualifier_specifiers_nla ANTI_TYPE { let { storage = mkStorage $1 ; typeQuals = mkTypeQuals $1 ; v = getANTI_TYPE $2 ; l = $1 `srcspan` $2 } in (AntiTypeDeclSpec storage typeQuals v l, AntiTypeDecl v l) } | nontypedef_declaration_specifiers_nla { $1 } | typedef_declaration_specifiers_nla { $1 } nontypedef_declaration_specifiers :: { (DeclSpec, Decl) } nontypedef_declaration_specifiers : ANTI_SPEC { let dspec = AntiDeclSpec (getANTI_SPEC $1) (srclocOf $1) in (dspec, DeclRoot (srclocOf $1)) } | storage_qualifier_specifiers %prec NAMED {% do{ dspec <- mkDeclSpec $1 ; return (dspec, DeclRoot (srclocOf $1)) } } | type_specifier {% do{ dspec <- mkDeclSpec [$1] ; return (dspec, DeclRoot (srclocOf $1) ) } } | type_specifier declaration_specifiers_rlist {% do{ dspec <- mkDeclSpec ($1 : rev $2) ; return (dspec, DeclRoot ($1 `srcspan` $2)) } } | storage_qualifier_specifiers type_specifier {% do{ dspec <- mkDeclSpec ($1 ++ [$2]) ; return $(dspec, DeclRoot ($1 `srcspan` $2)) } } | storage_qualifier_specifiers type_specifier declaration_specifiers_rlist {% do{ dspec <- mkDeclSpec ($1 ++ $2 : rev $3) ; return (dspec, DeclRoot ($1 `srcspan` $3)) } } nontypedef_declaration_specifiers_nla :: { (DeclSpec, Decl) } nontypedef_declaration_specifiers_nla : ANTI_SPEC { let dspec = AntiDeclSpec (getANTI_SPEC $1) (srclocOf $1) in (dspec, DeclRoot (srclocOf $1)) } | storage_qualifier_specifiers_nla %prec NAMED {% do{ dspec <- mkDeclSpec $1 ; return (dspec, DeclRoot (srclocOf $1)) } } | type_specifier {% do{ dspec <- mkDeclSpec [$1] ; return (dspec, DeclRoot (srclocOf $1) ) } } | type_specifier declaration_specifiers_rlist {% do{ dspec <- mkDeclSpec ($1 : rev $2) ; return (dspec, DeclRoot ($1 `srcspan` $2)) } } | storage_qualifier_specifiers_nla type_specifier {% do{ dspec <- mkDeclSpec ($1 ++ [$2]) ; return $(dspec, DeclRoot ($1 `srcspan` $2)) } } | storage_qualifier_specifiers_nla type_specifier declaration_specifiers_rlist {% do{ dspec <- mkDeclSpec ($1 ++ $2 : rev $3) ; return (dspec, DeclRoot ($1 `srcspan` $3)) } } typedef_declaration_specifiers :: { (DeclSpec, Decl) } typedef_declaration_specifiers : typedef_name {% do{ dspec <- mkDeclSpec [$1] ; return (dspec, DeclRoot (srclocOf $1)) } } | typedef_name storage_qualifier_specifiers {% do{ dspec <- mkDeclSpec ($1 : $2) ; return (dspec, DeclRoot ($1 `srcspan` $2)) } } | storage_qualifier_specifiers typedef_name {% do{ dspec <- mkDeclSpec ($1 ++ [$2]) ; return (dspec, DeclRoot ($1 `srcspan` $2)) } } | storage_qualifier_specifiers typedef_name storage_qualifier_specifiers {% do{ dspec <- mkDeclSpec ($1 ++ $2 : $3) ; return (dspec, DeclRoot ($1 `srcspan` $3)) } } typedef_declaration_specifiers_nla :: { (DeclSpec, Decl) } typedef_declaration_specifiers_nla : typedef_name {% do{ dspec <- mkDeclSpec [$1] ; return (dspec, DeclRoot (srclocOf $1)) } } | typedef_name storage_qualifier_specifiers {% do{ dspec <- mkDeclSpec ($1 : $2) ; return (dspec, DeclRoot ($1 `srcspan` $2)) } } | storage_qualifier_specifiers_nla typedef_name {% do{ dspec <- mkDeclSpec ($1 ++ [$2]) ; return (dspec, DeclRoot ($1 `srcspan` $2)) } } | storage_qualifier_specifiers_nla typedef_name storage_qualifier_specifiers {% do{ dspec <- mkDeclSpec ($1 ++ $2 : $3) ; return (dspec, DeclRoot ($1 `srcspan` $3)) } } declaration_specifiers_rlist :: { RevList TySpec } declaration_specifiers_rlist : storage_class_specifier { rsingleton $1 } | type_specifier { rsingleton $1 } | type_qualifier { rsingleton $1 } | attribute_specifier { rapp (map TSAttr $1) rnil } | declaration_specifiers_rlist storage_class_specifier { rcons $2 $1 } | declaration_specifiers_rlist type_specifier { rcons $2 $1 } | declaration_specifiers_rlist type_qualifier { rcons $2 $1 } | declaration_specifiers_rlist attribute_specifier { rapp (map TSAttr $2) $1 } -- This production allows us to add storage class specifiers and type qualifiers -- to an anti-quoted type. storage_qualifier_specifiers :: { [TySpec]} storage_qualifier_specifiers : storage_qualifier_specifiers_rlist { rev $1 } storage_qualifier_specifiers_rlist :: { RevList TySpec } storage_qualifier_specifiers_rlist : storage_class_specifier { rsingleton $1 } | type_qualifier { rsingleton $1 } | attribute_specifier { rapp (map TSAttr $1) rnil } | storage_qualifier_specifiers_rlist storage_class_specifier { rcons $2 $1 } | storage_qualifier_specifiers_rlist type_qualifier { rcons $2 $1 } | storage_qualifier_specifiers_rlist attribute_specifier { rapp (map TSAttr $2) $1 } storage_qualifier_specifiers_nla :: { [TySpec]} storage_qualifier_specifiers_nla : storage_qualifier_specifiers_rlist_nla { rev $1 } storage_qualifier_specifiers_rlist_nla :: { RevList TySpec } storage_qualifier_specifiers_rlist_nla : storage_class_specifier { rsingleton $1 } | type_qualifier { rsingleton $1 } | storage_qualifier_specifiers_rlist_nla storage_class_specifier { rcons $2 $1 } | storage_qualifier_specifiers_rlist_nla type_qualifier { rcons $2 $1 } | storage_qualifier_specifiers_rlist_nla attribute_specifier { rapp (map TSAttr $2) $1 } init_declarator_rlist :: { RevList Init } init_declarator_rlist : init_declarator { rsingleton $1 } | init_declarator_rlist ',' init_declarator { rcons $3 $1 } init_declarator :: { Init } init_declarator : declarator attributes_and_label { let { (ident, declToDecl) = $1 ; decl = declToDecl (declRoot ident) ; (attrs, asmlabel) = unLoc $2 } in Init ident decl asmlabel Nothing attrs (ident `srcspan` $2) } | declarator attributes_and_label '=' initializer { let { (ident, declToDecl) = $1 ; decl = declToDecl (declRoot ident) ; (attrs, asmlabel) = unLoc $2 } in Init ident decl asmlabel (Just $4) attrs (ident `srcspan` $4) } | declarator error {% do{ let (ident, declToDecl) = $1 ; let decl = declToDecl (declRoot ident) ; expected ["'='"] Nothing } } storage_class_specifier :: { TySpec } storage_class_specifier : 'auto' { TSauto (srclocOf $1) } | 'register' { TSregister (srclocOf $1) } | 'static' { TSstatic (srclocOf $1) } | 'extern' { TSextern Nothing (srclocOf $1) } | 'extern' string_literal { TSextern (Just $2) ($1 `srcspan` $2) } | 'typedef' { TStypedef (srclocOf $1) } -- Clang blocks | '__block' { TS__block (srclocOf $1) } -- Objective-C | '__weak' { TSObjC__weak (srclocOf $1) } | '__strong' { TSObjC__strong (srclocOf $1) } | '__unsafe_unretained' { TSObjC__unsafe_unretained (srclocOf $1) } type_specifier :: { TySpec } type_specifier : 'void' { TSvoid (srclocOf $1) } | 'char' { TSchar (srclocOf $1) } | 'short' { TSshort (srclocOf $1) } | 'int' { TSint (srclocOf $1) } | 'long' { TSlong (srclocOf $1) } | 'float' { TSfloat (srclocOf $1) } | 'double' { TSdouble (srclocOf $1) } | 'signed' { TSsigned (srclocOf $1) } | 'unsigned' { TSunsigned (srclocOf $1) } | struct_or_union_specifier { $1 } | enum_specifier { $1 } -- C99 | '_Bool' { TS_Bool (srclocOf $1) } | '_Complex' { TS_Complex (srclocOf $1) } | '_Imaginary' { TS_Imaginary (srclocOf $1) } -- GCC | '__builtin_va_list' { TSva_list (srclocOf $1) } struct_or_union_specifier :: { TySpec } struct_or_union_specifier : struct_or_union identifier_or_typedef { (unLoc $1) (Just $2) Nothing [] ($1 `srcspan` $2) } | struct_or_union attribute_specifiers identifier_or_typedef { (unLoc $1) (Just $3) Nothing $2 ($1 `srcspan` $3) } | struct_or_union lbrace struct_declaration_rlist '}' { (unLoc $1) Nothing (Just (rev $3)) [] ($1 `srcspan` $4) } | struct_or_union lbrace struct_declaration_rlist error {% unclosed ($1 <--> rev $3) "{" } | struct_or_union identifier_or_typedef lbrace struct_declaration_rlist '}' { (unLoc $1) (Just $2) (Just (rev $4)) [] ($1 `srcspan` $5) } | struct_or_union identifier_or_typedef lbrace struct_declaration_rlist error {% unclosed ($1 <--> rev $4) "{" } | struct_or_union attribute_specifiers identifier_or_typedef lbrace struct_declaration_rlist '}' { (unLoc $1) (Just $3) (Just (rev $5)) $2 ($1 `srcspan` $6) } | struct_or_union attribute_specifiers lbrace struct_declaration_rlist '}' { (unLoc $1) Nothing (Just (rev $4)) $2 ($1 `srcspan` $5) } | struct_or_union attribute_specifiers identifier_or_typedef lbrace struct_declaration_rlist error {% unclosed ($1 <--> rev $5) "{" } struct_or_union :: { L (Maybe Id -> Maybe [FieldGroup] -> [Attr] -> SrcLoc -> TySpec) } struct_or_union : 'struct' { L (locOf $1) TSstruct } | 'union' { L (locOf $1) TSunion } struct_declaration_rlist :: { RevList FieldGroup } struct_declaration_rlist : struct_declaration { rsingleton $1 } | ANTI_SDECLS { rsingleton (AntiSdecls (getANTI_SDECLS $1) (srclocOf $1)) } | struct_declaration_rlist struct_declaration { rcons $2 $1 } | struct_declaration_rlist ANTI_SDECLS { rcons (AntiSdecls (getANTI_SDECLS $2) (srclocOf $2)) $1 } struct_declaration :: { FieldGroup } struct_declaration : ANTI_SPEC struct_declarator_rlist semi { let dspec = AntiDeclSpec (getANTI_SPEC $1) (srclocOf $1) in FieldGroup dspec (map ($ Nothing) (rev $2)) ($1 `srcspan` $3) } | specifier_qualifier_list semi {% do{ dspec <- mkDeclSpec $1 ; gcc <- useGccExts ; c11 <- useC11Exts ; when (not gcc && not c11) $ expectedAt $2 ["declarator"] Nothing ; checkAnonymousStructOrUnion $2 dspec ; return $ FieldGroup dspec [] ($1 `srcspan` $2) } } | specifier_qualifier_list struct_declarator_rlist semi {% do{ dspec <- mkDeclSpec $1 ; return $ FieldGroup dspec (map ($ Nothing) (rev $2)) ($1 `srcspan` $3) } } | ANTI_TYPE struct_declarator_rlist semi {% do{ let v = getANTI_TYPE $1 ; let dspec = AntiTypeDeclSpec [] [] v (srclocOf $1) ; let decl = AntiTypeDecl v (srclocOf $1) ; return $ FieldGroup dspec (map ($ Just decl) (rev $2)) ($1 `srcspan` $3) } } | ANTI_SDECL { AntiSdecl (getANTI_SDECL $1) (srclocOf $1) } specifier_qualifier_list :: { [TySpec] } specifier_qualifier_list : type_specifier specifier_qualifier_rlist { $1 : rev $2 } | type_qualifier_rlist type_specifier specifier_qualifier_rlist { rev $1 ++ [$2] ++ rev $3 } | typedef_name { [$1] } | typedef_name type_qualifier_rlist { $1 : rev $2 } | type_qualifier_rlist typedef_name { rev $1 ++ [$2] } | type_qualifier_rlist typedef_name type_qualifier_rlist { rev $1 ++ [$2] ++ rev $3 } specifier_qualifier_rlist :: { RevList TySpec } specifier_qualifier_rlist : {- empty -} { rnil } | specifier_qualifier_rlist type_specifier { rcons $2 $1 } | specifier_qualifier_rlist type_qualifier { rcons $2 $1 } | specifier_qualifier_rlist attribute_specifier { $1 } struct_declarator_rlist :: { RevList (Maybe Decl -> Field) } struct_declarator_rlist : struct_declarator { rsingleton $1 } | struct_declarator_rlist ',' struct_declarator { rcons $3 $1 } struct_declarator :: { Maybe Decl -> Field } struct_declarator : declarator { \maybe_decl -> let { (ident, declToDecl) = $1 ; decl = declToDecl (fromMaybe (declRoot ident) maybe_decl) } in Field (Just ident) (Just decl) Nothing (srclocOf decl) } | declarator attribute_specifiers { \maybe_decl -> let { (ident, declToDecl) = $1 ; decl = declToDecl (fromMaybe (declRoot ident) maybe_decl) } in Field (Just ident) (Just decl) Nothing (srclocOf decl) } | ':' constant_expression { \maybe_decl -> Field Nothing maybe_decl (Just $2) ($1 `srcspan` $2) } | declarator ':' constant_expression { \maybe_decl -> let { (ident, declToDecl) = $1 ; decl = declToDecl (fromMaybe (declRoot ident) maybe_decl) } in Field (Just ident) (Just decl) (Just $3) (srclocOf decl) } enum_specifier :: { TySpec } enum_specifier : 'enum' identifier_or_typedef { TSenum (Just $2) [] [] ($1 `srcspan` $2) } | 'enum' attribute_specifiers identifier_or_typedef { TSenum (Just $3) [] $2 ($1 `srcspan` $3) } | 'enum' lbrace enumerator_rlist '}' { TSenum Nothing (rev $3) [] ($1 `srcspan` $4) } | 'enum' identifier_or_typedef lbrace enumerator_rlist '}' { TSenum (Just $2) (rev $4) [] ($1 `srcspan` $5)} enumerator_rlist :: { RevList CEnum } enumerator_rlist : enumerator { rsingleton $1 } | ANTI_ENUMS { rsingleton (AntiEnums (getANTI_ENUMS $1) (srclocOf $1)) } | enumerator_rlist ',' { $1 } | enumerator_rlist ',' enumerator { rcons $3 $1 } | enumerator_rlist ',' ANTI_ENUMS { rcons (AntiEnums (getANTI_ENUMS $3) (srclocOf $3)) $1 } enumerator :: { CEnum } enumerator: identifier { CEnum $1 Nothing (srclocOf $1)} | identifier '=' constant_expression { CEnum $1 (Just $3) ($1 `srcspan` $3) } | ANTI_ENUM { AntiEnum (getANTI_ENUM $1) (srclocOf $1) } type_qualifier :: { TySpec } type_qualifier : 'const' { TSconst (srclocOf $1) } | 'volatile' { TSvolatile (srclocOf $1) } | ANTI_TYPE_QUAL { TSAntiTypeQual (getANTI_TYPE_QUAL $1) (srclocOf $1) } | ANTI_TYPE_QUALS { TSAntiTypeQuals (getANTI_TYPE_QUALS $1) (srclocOf $1) } -- C99 | 'inline' { TSinline (srclocOf $1) } | 'restrict' { TSrestrict (srclocOf $1) } -- GCC | '__restrict' { TS__restrict (srclocOf $1) } -- CUDA | '__device__' { TSCUDAdevice (srclocOf $1) } | '__global__' { TSCUDAglobal (srclocOf $1) } | '__host__' { TSCUDAhost (srclocOf $1) } | '__constant__' { TSCUDAconstant (srclocOf $1) } | '__shared__' { TSCUDAshared (srclocOf $1) } | '__restrict__' { TSCUDArestrict (srclocOf $1) } | '__noinline__' { TSCUDAnoinline (srclocOf $1) } -- OpenCL | 'private' { TSCLprivate (srclocOf $1) } | '__private' { TSCLprivate (srclocOf $1) } | 'local' { TSCLlocal (srclocOf $1) } | '__local' { TSCLlocal (srclocOf $1) } | 'global' { TSCLglobal (srclocOf $1) } | '__global' { TSCLglobal (srclocOf $1) } | 'constant' { TSCLconstant (srclocOf $1) } | '__constant' { TSCLconstant (srclocOf $1) } | 'read_only' { TSCLreadonly (srclocOf $1) } | '__read_only' { TSCLreadonly (srclocOf $1) } | 'write_only' { TSCLwriteonly (srclocOf $1) } | '__write_only' { TSCLwriteonly (srclocOf $1) } | 'kernel' { TSCLkernel (srclocOf $1) } | '__kernel' { TSCLkernel (srclocOf $1) } -- Consider the following C program: -- -- typedef struct foo { -- int a; -- } foo; -- -- void f(foo* (foo)); -- -- In the grammar in the C99 standard, a parameter declaration can result from -- either a declarator or an abstract declarator. This produces an ambiguity -- when a typedef name appears after '(' because we can't tell whether or not it -- is an item in a parameter list for a function that is part of an abstract -- declarator, or if is just a parenthesized (standard) declarator. This -- ambiguity exists in the definition of f in the above program. -- -- To solve this ambiguity, we split the the declarator rule to handle the -- identifier and typedef name cases separately, and, furthermore, copy the -- typedef name declarator rule and remove the cases that leads to ambiguity -- when a declarator is used in a parameter list declaration. identifier_declarator :: { (Id, Decl -> Decl) } identifier_declarator : identifier_direct_declarator { $1 } | pointer identifier_direct_declarator { let (ident, dirDecl) = $2 in (ident, dirDecl . $1) } identifier_direct_declarator :: { (Id, Decl -> Decl) } identifier_direct_declarator : identifier { ($1, id) } | '(' identifier_declarator ')' { $2 } | '(' identifier_declarator error {%do { let (ident, declToDecl) = $2 ; let decl = declToDecl (declRoot ident) ; unclosed ($1 <--> decl) "(" } } | identifier_direct_declarator array_declarator { let (ident, declToDecl) = $1 in (ident, declToDecl . $2) } | identifier_direct_declarator '(' ')' { let { (ident, declToDecl) = $1 ; proto = mkOldProto [] } in (ident, declToDecl . proto) } | identifier_direct_declarator '(' parameter_type_list ')' { let { (ident, declToDecl) = $1 ; proto = mkProto $3 } in (ident, declToDecl . proto) } | identifier_direct_declarator '(' identifier_rlist ')' { let { (ident, declToDecl) = $1 ; proto = mkOldProto (rev $3) } in (ident, declToDecl . proto) } typedef_declarator :: { (Id, Decl -> Decl) } typedef_declarator : typedef_direct_declarator { $1 } | pointer typedef_direct_declarator { let (ident, dirDecl) = $2 in (ident, dirDecl . $1) } typedef_direct_declarator :: { (Id, Decl -> Decl) } typedef_direct_declarator : NAMED { (Id (getNAMED $1) (srclocOf $1), id) } | '(' typedef_declarator ')' { $2 } | '(' typedef_declarator error {%do { let (ident, declToDecl) = $2 ; let decl = declToDecl (declRoot ident) ; unclosed ($1 <--> decl) "(" } } | typedef_direct_declarator array_declarator { let (ident, declToDecl) = $1 in (ident, declToDecl . $2) } | typedef_direct_declarator '(' ')' { let { (ident, declToDecl) = $1 ; proto = mkOldProto [] } in (ident, declToDecl . proto) } | typedef_direct_declarator '(' parameter_type_list ')' { let { (ident, declToDecl) = $1 ; proto = mkProto $3 } in (ident, declToDecl . proto) } | typedef_direct_declarator '(' identifier_rlist ')' { let { (ident, declToDecl) = $1 ; proto = mkOldProto (rev $3) } in (ident, declToDecl . proto) } -- Objective-C | OBJCNAMED { (Id (getOBJCNAMED $1) (srclocOf $1), id) } declarator :: { (Id, Decl -> Decl) } declarator : identifier_declarator { $1 } | typedef_declarator { $1 } parameter_typedef_declarator :: { (Id, Decl -> Decl) } parameter_typedef_declarator : parameter_typedef_direct_declarator { $1 } | pointer parameter_typedef_direct_declarator { let (ident, dirDecl) = $2 in (ident, dirDecl . $1) } parameter_typedef_direct_declarator :: { (Id, Decl -> Decl) } parameter_typedef_direct_declarator : NAMED { (Id (getNAMED $1) (srclocOf $1), id) } | '(' pointer parameter_typedef_direct_declarator ')' { let (ident, dirDecl) = $3 in (ident, dirDecl . $2) } | parameter_typedef_direct_declarator array_declarator { let (ident, declToDecl) = $1 in (ident, declToDecl . $2) } | parameter_typedef_direct_declarator '(' ')' { let { (ident, declToDecl) = $1 ; proto = mkOldProto [] } in (ident, declToDecl . proto) } | parameter_typedef_direct_declarator '(' parameter_type_list ')' { let { (ident, declToDecl) = $1 ; proto = mkProto $3 } in (ident, declToDecl . proto) } | parameter_typedef_direct_declarator '(' identifier_rlist ')' { let { (ident, declToDecl) = $1 ; proto = mkOldProto (rev $3) } in (ident, declToDecl . proto) } -- Objective-C | OBJCNAMED { (Id (getOBJCNAMED $1) (srclocOf $1), id) } parameter_declarator :: { (Id, Decl -> Decl) } parameter_declarator : identifier_declarator { $1 } | parameter_typedef_declarator { $1 } array_declarator :: { Decl -> Decl } array_declarator : '[' ']' { mkArray [] (NoArraySize ($1 `srcspan` $2)) } | '[' error {% unclosed (locOf $1) "[" } | '[' type_qualifier_rlist ']' { mkArray (rev $2) (NoArraySize ($1 `srcspan` $3)) } | '[' assignment_expression ']' { mkArray [] (ArraySize False $2 (srclocOf $2)) } | '[' type_qualifier_rlist assignment_expression ']' { mkArray (rev $2) (ArraySize False $3 (srclocOf $3)) } | '[' 'static' assignment_expression ']' { mkArray [] (ArraySize True $3 (srclocOf $3)) } | '[' 'static' type_qualifier_rlist assignment_expression ']' { mkArray (rev $3) (ArraySize True $4 (srclocOf $4)) } | '[' type_qualifier_rlist 'static' assignment_expression ']' { mkArray (rev $2) (ArraySize True $4 (srclocOf $4)) } | '[' '*' ']' { mkArray [] (VariableArraySize ($1 `srcspan` $3)) } | '[' type_qualifier_rlist '*' ']' { mkArray (rev $2) (VariableArraySize ($1 `srcspan` $4)) } -- Extension: blocks -- -- Any declarator for a function pointer turns into a block declarator by replacing the '*' by a '^'. -- However, block pointers can only point to function types. -- pointer :: { Decl -> Decl } pointer : '*' { mkPtr [] } | '*' type_qualifier_rlist { mkPtr (rev $2) } | '*' pointer { $2 . mkPtr [] } | '*' type_qualifier_rlist pointer { $3 . mkPtr (rev $2) } -- Clang blocks | '^' {% mkBlockPtr (locOf $1) [] } | '^' type_qualifier_rlist {% mkBlockPtr (locOf $1) (rev $2) } | '^' pointer {% ($2 .) `liftM` mkBlockPtr (locOf $1) [] } | '^' type_qualifier_rlist pointer {% ($3 .) `liftM` mkBlockPtr (locOf $1) (rev $2) } type_qualifier_list :: { [TypeQual] } type_qualifier_list : type_qualifier_rlist { mkTypeQuals (rev $1) } type_qualifier_rlist :: { RevList TySpec } type_qualifier_rlist : type_qualifier { rsingleton $1 } | type_qualifier_rlist type_qualifier { rcons $2 $1 } parameter_type_list :: { Params } parameter_type_list : parameter_rlist { let params = rev $1 in Params params False (srclocOf params) } | parameter_rlist ',' '...' { let params = rev $1 in Params params True (params `srcspan` $3) } parameter_list :: { [Param] } parameter_list : parameter_rlist { rev $1 } parameter_rlist :: { RevList Param } parameter_rlist : parameter_declaration { rsingleton $1 } | ANTI_PARAMS { rsingleton (AntiParams (getANTI_PARAMS $1) (srclocOf $1)) } | parameter_rlist ',' parameter_declaration { rcons $3 $1 } | parameter_rlist ',' ANTI_PARAMS { rcons (AntiParams (getANTI_PARAMS $3) (srclocOf $3)) $1 } parameter_declaration :: { Param } parameter_declaration : declaration_specifiers { let (dspec, decl) = $1 in Param Nothing dspec decl (dspec `srcspan` decl) } | declaration_specifiers parameter_declarator { let { (dspec, declRoot) = $1 ; (ident, declToDecl) = $2 ; decl = declToDecl declRoot } in Param (Just ident) dspec decl (ident `srcspan` decl) } | declaration_specifiers abstract_declarator { let { (dspec, declRoot) = $1 ; decl = $2 declRoot } in Param Nothing dspec decl (dspec `srcspan` decl) } | ANTI_PARAM { AntiParam (getANTI_PARAM $1) (srclocOf $1) } -- The type_declaration rule is the parameter_declaration rule without the -- ANTI_PARAM option. This allows us to parse type declarations easily for later -- antiquoting. type_declaration :: { Type } type_declaration : declaration_specifiers { let (dspec, decl) = $1 in Type dspec decl (dspec `srcspan` decl) } | declaration_specifiers parameter_declarator { let { (dspec, declRoot) = $1 ; (ident, declToDecl) = $2 ; decl = declToDecl declRoot } in Type dspec decl (dspec `srcspan` decl) } | declaration_specifiers abstract_declarator { let { (dspec, declRoot) = $1 ; decl = $2 declRoot } in Type dspec decl (dspec `srcspan` decl) } identifier_rlist :: { RevList Id } identifier_rlist : identifier { rsingleton $1 } | identifier_rlist ',' identifier { rcons $3 $1 } type_name :: { Type } type_name : ANTI_SPEC { let dspec = AntiDeclSpec (getANTI_SPEC $1) (srclocOf $1) in Type dspec (declRoot $1) (srclocOf $1) } | specifier_qualifier_list {% do{ dspec <- mkDeclSpec $1 ; return $ Type dspec (declRoot $1) (srclocOf $1) } } | ANTI_SPEC abstract_declarator { let { dspec = AntiDeclSpec (getANTI_SPEC $1) (srclocOf $1) ; decl = $2 (declRoot $1) } in Type dspec decl (dspec `srcspan` decl) } | specifier_qualifier_list abstract_declarator {% do{ let decl = $2 (declRoot $1) ; dspec <- mkDeclSpec $1 ; return $ Type dspec decl (dspec `srcspan` decl) } } | ANTI_TYPE { AntiType (getANTI_TYPE $1) (srclocOf $1) } | type_qualifier_list ANTI_TYPE { let { v = getANTI_TYPE $2 ; decl = declRoot (AntiTypeDecl v (srclocOf $2)) } in Type (AntiTypeDeclSpec [] $1 v (srclocOf $2)) decl ($1 `srcspan` decl) } | ANTI_TYPE abstract_declarator { let { v = getANTI_TYPE $1 ; decl = $2 (AntiTypeDecl v (srclocOf $1)) } in Type (AntiTypeDeclSpec [] [] v (srclocOf $1)) decl ($1 `srcspan` decl) } | type_qualifier_list ANTI_TYPE abstract_declarator { let { v = getANTI_TYPE $2 ; decl = $3 (AntiTypeDecl v (srclocOf $2)) } in Type (AntiTypeDeclSpec [] $1 v (srclocOf $2)) decl ($1 `srcspan` decl) } abstract_declarator :: { Decl -> Decl } abstract_declarator : pointer { $1 } | direct_abstract_declarator { $1 } | pointer direct_abstract_declarator { $2 . $1 } direct_abstract_declarator :: { Decl -> Decl } direct_abstract_declarator : '(' abstract_declarator ')' { $2 } | '(' abstract_declarator error {% do{ let decl = $2 (declRoot $1) ; unclosed ($1 <--> decl) "(" } } | array_declarator { $1 } | direct_abstract_declarator array_declarator { $1 . $2 } | '(' ')' { mkOldProto [] } | '(' parameter_type_list ')' { mkProto $2 } | direct_abstract_declarator '(' ')' { $1 . mkOldProto [] } | direct_abstract_declarator '(' parameter_type_list ')' { $1 . mkProto $3 } typedef_name :: { TySpec } typedef_name : NAMED { TSnamed (Id (getNAMED $1) (srclocOf $1)) [] (srclocOf $1) } | NAMED '<' identifier_rlist '>' {% do { assertObjCEnabled ($1 <--> $4) "To use protocol qualifiers, enable support for Objective-C" ; return $ TSnamed (Id (getNAMED $1) (srclocOf $1)) (rev $3) ($1 `srcspan` $4) } } | 'typename' identifier { TSnamed $2 [] (srclocOf $1) } | 'typename' identifier '<' identifier_rlist '>' {% do { assertObjCEnabled ($1 <--> $5) "To use protocol qualifiers, enable support for Objective-C" ; return $ TSnamed $2 (rev $4) ($1 `srcspan` $5) } } | 'typename' error {% expected ["identifier"] (Just "'typename'")} -- GCC | '__typeof__' '(' unary_expression_nlt ')' { TStypeofExp $3 ($1 `srcspan` $4) } | '__typeof__' '(' type_name ')' { TStypeofType $3 ($1 `srcspan` $4) } | '__typeof__' '(' type_name error {% unclosed ($2 <--> $3) "(" } -- Objective-C | OBJCNAMED { TSnamed (Id (getOBJCNAMED $1) (srclocOf $1)) [] (srclocOf $1) } | OBJCNAMED '<' identifier_rlist '>' {% do { assertObjCEnabled ($1 <--> $4) "To use protocol qualifiers, enable support for Objective-C" ; return $ TSnamed (Id (getOBJCNAMED $1) (srclocOf $1)) (rev $3) ($1 `srcspan` $4) } } initializer :: { Initializer } initializer : assignment_expression { ExpInitializer $1 (srclocOf $1) } | lbrace initializer_rlist '}' { CompoundInitializer (rev $2) ($1 `srcspan` $3) } | lbrace initializer_rlist error {% do{ let (_, inits) = unzip (rev $2) ; unclosed ($1 <--> inits) "{" } } | lbrace initializer_rlist ',' '}' { CompoundInitializer (rev $2) ($1 `srcspan` $4) } | lbrace initializer_rlist ',' error {% unclosed ($1 <--> $3) "{" } | ANTI_INIT { AntiInit (getANTI_INIT $1) (srclocOf $1) } initializer_rlist :: { RevList (Maybe Designation, Initializer) } initializer_rlist : initializer { rsingleton (Nothing, $1) } | ANTI_INITS { rsingleton (Nothing, AntiInits (getANTI_INITS $1) (srclocOf $1)) } | designation initializer { rsingleton (Just $1, $2) } | initializer_rlist ',' initializer { rcons (Nothing, $3) $1 } | initializer_rlist ',' designation initializer { rcons (Just $3, $4) $1 } designation :: { Designation } designation : designator_rlist '=' { let designators = rev $1 in Designation designators (designators `srcspan` $2) } designator_rlist :: { RevList Designator } designator_rlist : designator { rsingleton $1 } | designator_rlist designator { rcons $2 $1 } designator :: { Designator } designator : '[' constant_expression ']' { IndexDesignator $2 ($1 `srcspan` $3) } | '.' identifier { MemberDesignator $2 ($1 `srcspan` $2) } {------------------------------------------------------------------------------ - - Statements - ------------------------------------------------------------------------------} statement :: { Stm } statement : labeled_statement { $1 } | compound_statement { $1 } | expression_statement { $1 } | selection_statement { $1 } | iteration_statement { $1 } | jump_statement { $1 } | '#pragma' { Pragma (getPRAGMA $1) (srclocOf $1) } | comment statement { $1 $2 } | ANTI_ESCSTM { AntiEscStm (getANTI_ESCSTM $1) (srclocOf $1) } | ANTI_COMMENT error {% expected ["statement"] Nothing } | ANTI_PRAGMA { AntiPragma (getANTI_PRAGMA $1) (srclocOf $1) } | ANTI_STM { AntiStm (getANTI_STM $1) (srclocOf $1) } -- GCC | asm_statement { $1 } -- Objective-C | objc_at_statement { $1 } comment :: { Stm -> Stm } comment : '//' { mkCommentStm $1 } | ANTI_COMMENT { \stm -> AntiComment (getANTI_COMMENT $1) stm (srclocOf $1) } statement_list :: { [Stm] } statement_list : comment { [$1 (Exp Nothing noLoc)] } | statement_rlist { rev $1 } | statement_rlist comment { rev (rcons ($2 (Exp Nothing noLoc)) $1) } statement_rlist :: { RevList Stm } statement_rlist : statement { rsingleton $1 } | ANTI_STMS { rsingleton (AntiStms (getANTI_STMS $1) (srclocOf $1)) } | comment ANTI_STMS { AntiStms (getANTI_STMS $2) (srclocOf $2) `rcons` $1 (Exp Nothing noLoc) `rcons` rnil } | statement_rlist statement { $2 `rcons` $1 } | statement_rlist ANTI_STMS { AntiStms (getANTI_STMS $2) (srclocOf $2) `rcons` $1 } | statement_rlist comment ANTI_STMS { AntiStms (getANTI_STMS $3) (srclocOf $3) `rcons` $2 (Exp Nothing noLoc) `rcons` $1 } labeled_statement :: { Stm } labeled_statement : identifier ':' error {% expected ["statement"] (Just "label") } | identifier ':' statement { Label $1 [] $3 ($1 `srcspan` $3) } | 'case' constant_expression error {% do { gcc_enabled <- useGccExts ; let options = if gcc_enabled then ["`:'", "`...'"] else ["`:'"] ; expected options Nothing } } | 'case' constant_expression ':' error {% expected ["statement"] Nothing } | 'case' constant_expression ':' statement { Case $2 $4 ($1 `srcspan` $4) } | 'case' constant_expression '...' constant_expression error {% expected ["`:'"] Nothing } | 'case' constant_expression '...' constant_expression ':' error {% expected ["statement"] Nothing } | 'case' constant_expression '...' constant_expression ':' statement {% gccOnly "To use ranges in case statements, enable GCC extensions" $ CaseRange $2 $4 $6 ($1 `srcspan` $6) } | 'default' error {% expected ["`:'"] (Just "`default'")} | 'default' ':' error {% expected ["statement"] Nothing } | 'default' ':' statement { Default $3 ($1 `srcspan` $3) } -- GCC | identifier ':' attribute_specifiers ';' { Label $1 $3 (Exp Nothing noLoc) ($1 `srcspan` $4) } compound_statement :: { Stm } compound_statement: '{' begin_scope end_scope '}' { mkBlock [] ($1 `srcspan` $4) } | '{' begin_scope block_item_list end_scope '}' { mkBlock $3 ($1 `srcspan` $5) } | '{' begin_scope error {% unclosed (locOf $3) "{" } block_item_list :: { [BlockItem] } block_item_list : block_item_rlist { rev $1 } | block_item_rlist comment { rev (rcons (BlockStm ($2 (Exp Nothing noLoc))) $1) } block_item_rlist :: { RevList BlockItem } block_item_rlist : block_item_no_stm { rsingleton $1 } | comment block_item_no_stm { rsingleton $2 } | statement { rsingleton (BlockStm $1) } | block_item_rlist block_item_no_stm { rcons $2 $1 } | block_item_rlist comment block_item_no_stm { rcons $3 $1 } | block_item_rlist statement { rcons (BlockStm $2) $1 } block_item_no_stm :: { BlockItem } block_item_no_stm : declaration { BlockDecl $1 } | ANTI_DECLS { BlockDecl (AntiDecls (getANTI_DECLS $1) (srclocOf $1)) } | ANTI_STMS { BlockStm (AntiStms (getANTI_STMS $1) (srclocOf $1)) } | ANTI_ITEM { AntiBlockItem (getANTI_ITEM $1) (srclocOf $1) } | ANTI_ITEMS { AntiBlockItems (getANTI_ITEMS $1) (srclocOf $1) } block_item :: { BlockItem } block_item : statement { BlockStm $1 } | statement comment { BlockStm $1 } | block_item_no_stm { $1 } | comment block_item_no_stm { $2 } | block_item_no_stm comment { $1 } begin_scope :: { () } begin_scope : {% pushScope } end_scope :: { () } end_scope : {% popScope } expression_statement :: { Stm } expression_statement: ';' { Exp Nothing (srclocOf $1) } | expression_nlt ';' { Exp (Just $1) ($1 `srcspan` $2) } | expression_nlt error {% expected ["';'"] Nothing } selection_statement :: { Stm } selection_statement : 'if' '(' expression ')' statement { If $3 $5 Nothing ($1 `srcspan` $5) } | 'if' '(' expression ')' statement 'else' statement { If $3 $5 (Just $7) ($1 `srcspan` $7) } | 'if' error {% expected ["("] (Just "`if'") } | 'if' '(' expression error {% unclosed ($2 <--> $3) "(" } | 'switch' '(' expression ')' statement { Switch $3 $5 ($1 `srcspan` $5) } | 'switch' '(' expression error {% unclosed ($2 <--> $3) "(" } iteration_statement :: { Stm } iteration_statement : 'while' '(' expression ')' statement { While $3 $5 ($1 `srcspan` $5) } | 'while' '(' expression error {% unclosed ($2 <--> $3) "(" } | 'do' statement 'while' '(' expression ')' ';' { DoWhile $2 $5 ($1 `srcspan` $7) } | 'do' statement 'while' '(' expression error {% unclosed ($4 <--> $5) "(" } | 'for' '(' error {% expected ["expression", "declaration"] Nothing } | 'for' '(' declaration maybe_expression semi ')' statement { For (Left $3) $4 Nothing $7 ($1 `srcspan` $7) } | 'for' '(' maybe_expression_nlt semi maybe_expression semi ')' statement { For (Right $3) $5 Nothing $8 ($1 `srcspan` $8) } | 'for' '(' maybe_expression_nlt semi maybe_expression semi error {% unclosed ($2 <--> $6) "(" } | 'for' '(' declaration maybe_expression semi expression ')' statement { For (Left $3) $4 (Just $6) $8 ($1 `srcspan` $8) } | 'for' '(' maybe_expression_nlt semi maybe_expression semi expression ')' statement { For (Right $3) $5 (Just $7) $9 ($1 `srcspan` $9) } | 'for' '(' maybe_expression_nlt semi maybe_expression semi expression error {% unclosed ($2 <--> $7) "(" } jump_statement :: { Stm } jump_statement : 'goto' identifier ';' { Goto $2 ($1 `srcspan` $3) } | 'goto' error {% expected ["identifier"] (Just "`goto'") } | 'goto' identifier error {% expected ["';'"] Nothing } | 'continue' ';' { Continue ($1 `srcspan` $2) } | 'continue' error {% expected ["';'"] (Just "`continue'") } | 'break' ';' { Break ($1 `srcspan` $2) } | 'break' error {% expected ["';'"] (Just "`break'") } | 'return' ';' { Return Nothing ($1 `srcspan` $2) } | 'return' error {% expected ["';'", "expression"] Nothing } | 'return' expression ';' { Return (Just $2) ($1 `srcspan` $3) } | 'return' expression error {% expected ["';'"] Nothing } {------------------------------------------------------------------------------ - - External definitions - ------------------------------------------------------------------------------} translation_unit :: { [Definition] } translation_unit : translation_unit_rlist { rev $1 } translation_unit_rlist :: { RevList Definition } translation_unit_rlist : {- empty -} { rnil } | comment { rnil } | translation_unit_rlist external_declaration { rcons $2 $1 } | translation_unit_rlist ANTI_EDECLS { rcons (AntiEdecls (getANTI_EDECLS $2) (srclocOf $2)) $1 } external_declaration :: { Definition } external_declaration : external_declaration_ { $1 } | external_declaration_ comment { $1 } -- Objective-C | objc_class_declaration { $1 } | objc_interface { $1 } | objc_protocol_declaration { $1 } | objc_implementation { $1 } | objc_compatibility_alias { $1 } external_declaration_ :: { Definition } external_declaration_ : function_definition { FuncDef $1 (srclocOf $1) } | declaration { DecDef $1 (srclocOf $1) } | ANTI_FUNC { AntiFunc (getANTI_FUNC $1) (srclocOf $1) } | ANTI_ESC { AntiEsc (getANTI_ESC $1) (srclocOf $1) } | ANTI_EDECL { AntiEdecl (getANTI_EDECL $1) (srclocOf $1) } function_definition :: { Func } function_definition : declaration_specifiers declarator compound_statement {% do{ let (dspec, declRoot) = $1 ; let (ident, declToDecl) = $2 ; let blockItems = mkBlockItems $3 ; let decl = declToDecl declRoot ; case decl of { Proto protoDecl args _ -> return $ Func dspec ident protoDecl args blockItems (decl `srcspan` blockItems) ; OldProto protoDecl args _ -> return $ OldFunc dspec ident protoDecl args Nothing blockItems (decl `srcspan` blockItems) ; _ -> parserError (decl <--> blockItems) (text "bad function declaration") } } } | declaration_specifiers declarator declaration_rlist compound_statement {% do{ let (dspec, declRoot) = $1 ; let (ident, declToDecl) = $2 ; let argDecls = $3 ; let blockItems = mkBlockItems $4 ; let decl = declToDecl declRoot ; case decl of { OldProto protoDecl args _ -> return $ OldFunc dspec ident protoDecl args (Just (rev argDecls)) blockItems (decl `srcspan` blockItems) ; _ -> parserError (decl <--> blockItems) (text "bad function declaration") } } } -- To prevent ambiguity, the first declaration in a list of old-style function -- parameter declarations cannot start with an attribute. declaration_rlist :: { RevList InitGroup } declaration_rlist : declaration_nla { rsingleton $1 } | declaration_nla comment { rsingleton $1 } | ANTI_DECLS { rsingleton (AntiDecls (getANTI_DECLS $1) (srclocOf $1)) } | declaration_rlist declaration { rcons $2 $1 } | declaration_rlist declaration comment { rcons $2 $1 } | declaration_rlist ANTI_DECLS { rcons (AntiDecls (getANTI_DECLS $2) (srclocOf $2)) $1 } {------------------------------------------------------------------------------ - - GCC extensions - ------------------------------------------------------------------------------} attributes_and_label :: { L ([Attr], Maybe AsmLabel) } attributes_and_label : {- empty -} { L noLoc ([], Nothing) } | asmlabel { L (locOf $1) ([], Just $1) } | asmlabel attribute_specifiers { L ($1 <--> $2) ($2, Just $1) } | attribute_specifiers { L (locOf $1) ($1, Nothing) } | attribute_specifiers asmlabel { L ($1 <--> $2) ($1, Just $2) } | attribute_specifiers asmlabel attribute_specifiers { L ($1 <--> $3) ($1 ++ $3, Just $2) } asmlabel :: { AsmLabel } asmlabel : '__asm__' '(' error {% expected ["string literal"] Nothing } | '__asm__' '(' string_literal ')' { $3 } attribute_specifiers_opt :: { [Attr] } attribute_specifiers_opt : {- empty -} { [] } | attribute_specifiers { $1 } attribute_specifiers :: { [Attr] } attribute_specifiers : attribute_specifier { $1 } | attribute_specifiers attribute_specifier { $1 ++ $2 } attribute_specifier :: { [Attr] } attribute_specifier : '__attribute__' '(' '(' attribute_rlist ')' ')' { rev $4 } attribute_rlist :: { RevList Attr } attribute_rlist : attrib { rsingleton $1 } | attribute_rlist ',' attrib { rcons $3 $1 } | ANTI_ATTRS { rsingleton $ AntiAttrs (getANTI_ATTRS $1) (srclocOf $1) } attrib :: { Attr } attrib : attrib_name { Attr $1 [] (srclocOf $1)} | attrib_name '(' argument_expression_list ')' { Attr $1 $3 ($1 `srcspan` $4) } | ANTI_ATTR { AntiAttr (getANTI_ATTR $1) (srclocOf $1) } attrib_name :: { Id } attrib_name : identifier_or_typedef { $1 } | 'static' { Id "static" (srclocOf $1) } | 'extern' { Id "extern" (srclocOf $1) } | 'register' { Id "register" (srclocOf $1) } | '__block' { Id "__block" (srclocOf $1) } | 'typedef' { Id "typedef" (srclocOf $1) } | 'inline' { Id "inline" (srclocOf $1) } | 'auto' { Id "auto" (srclocOf $1) } | 'const' { Id "const" (srclocOf $1) } | 'volatile' { Id "volatile" (srclocOf $1) } | 'unsigned' { Id "unsigned" (srclocOf $1) } | 'long' { Id "long" (srclocOf $1) } | 'short' { Id "short" (srclocOf $1) } | 'signed' { Id "signed" (srclocOf $1) } | 'int' { Id "int" (srclocOf $1) } | 'char' { Id "char" (srclocOf $1) } | 'float' { Id "float" (srclocOf $1) } | 'double' { Id "double" (srclocOf $1) } | 'void' { Id "void" (srclocOf $1) } maybe_volatile :: { Bool } maybe_volatile : {- empty -} { False} | 'volatile' { True} asm_statement :: { Stm } asm_statement : '__asm__' maybe_volatile '(' string_literal ')' ';' { Asm $2 [] $4 [] [] [] ($1 `srcspan` $6) } | '__asm__' maybe_volatile '(' string_literal ':' asm_outs ')' ';' { Asm $2 [] $4 $6 [] [] ($1 `srcspan` $8) } | '__asm__' maybe_volatile '(' string_literal ':' asm_outs ':' asm_ins ')' ';' { Asm $2 [] $4 $6 $8 [] ($1 `srcspan` $10) } | '__asm__' maybe_volatile '(' string_literal ':' asm_outs ':' asm_ins ':' asm_clobbers ')' ';' { Asm $2 [] $4 $6 $8 $10 ($1 `srcspan` $12) } | '__asm__' maybe_volatile 'goto' '(' string_literal ':' ':' asm_ins ':' asm_clobbers ':' asm_goto_labels ')' ';' { AsmGoto $2 [] $5 $8 $10 $12 ($1 `srcspan` $14) } asm_ins :: { [AsmIn] } asm_ins : {- empty -} { [] } | asm_ins_rlist { rev $1 } asm_ins_rlist :: { RevList AsmIn } asm_ins_rlist : asm_in { rsingleton $1 } | asm_ins_rlist ',' asm_in { rcons $3 $1 } asm_in :: { AsmIn } asm_in : asm_symbolic_name_opt STRING '(' expression ')' { AsmIn $1 ((fst . getSTRING) $2) $4 } asm_outs :: { [AsmOut] } asm_outs : {- empty -} { [] } | asm_outs_rlist { rev $1 } asm_outs_rlist :: { RevList AsmOut } asm_outs_rlist : asm_out { rsingleton $1 } | asm_outs_rlist ',' asm_out { rcons $3 $1 } asm_out :: { AsmOut } asm_out : asm_symbolic_name_opt STRING '(' identifier ')' { AsmOut $1 ((fst . getSTRING) $2) $4 } asm_clobbers :: { [String] } asm_clobbers : {- empty -} { [] } | asm_clobbers_rlist { rev $1 } asm_clobbers_rlist :: { RevList String } asm_clobbers_rlist : asm_clobber { rsingleton $1 } | asm_clobbers_rlist ',' asm_clobber { rcons $3 $1 } asm_clobber :: { String } asm_clobber : STRING { (fst . getSTRING) $1 } asm_symbolic_name_opt :: { Maybe Id } asm_symbolic_name_opt : {- empty -} { Nothing } | '[' identifier ']' { Just $2 } asm_goto_labels :: { [Id] } asm_goto_labels : asm_goto_labels_rlist { rev $1 } asm_goto_labels_rlist :: { RevList Id } asm_goto_labels_rlist : identifier { rsingleton $1 } | asm_goto_labels_rlist ',' identifier { rcons $3 $1 } {------------------------------------------------------------------------------ - - Clang blocks - ------------------------------------------------------------------------------} -- Clang extension: block literal expression -- -- block-literal -> -- '^' [block-type] attribute_specifiers_opt compound-statement -- -- block-type -> -- '(' parameter-list ')' | specifier-qualifier-list abstract-declarator -- block_literal :: { Exp } block_literal : '^' attribute_specifiers_opt compound_statement {% do { assertBlocksEnabled ($1 <--> $3) "To use blocks, enable the blocks language extension" ; let items = mkBlockItems $3 ; return $ BlockLit (BlockVoid (srclocOf $1)) $2 items ($1 `srcspan` $3) } } | '^' '(' parameter_list ')' attribute_specifiers_opt compound_statement {% do { assertBlocksEnabled ($1 <--> $6) "To use blocks, enable blocks language extension" ; let items = mkBlockItems $6 ; return $ BlockLit (BlockParam $3 ($2 `srcspan` $4)) $5 items ($1 `srcspan` $6) } } | '^' specifier_qualifier_list abstract_declarator attribute_specifiers_opt compound_statement {% do { assertBlocksEnabled ($1 <--> $5) "To use blocks, enable blocks language extension" ; let decl = $3 (declRoot $2) ; let items = mkBlockItems $5 ; dspec <- mkDeclSpec $2 ; let typeLoc = dspec `srcspan` decl ; return $ BlockLit (BlockType (Type dspec decl typeLoc) typeLoc) $4 items ($1 `srcspan` $5) } } {------------------------------------------------------------------------------ - - Objective-C - ------------------------------------------------------------------------------} objc_key_value :: { ObjCDictElem } objc_key_value : assignment_expression ':' assignment_expression { ObjCDictElem $1 $3 ($1 `srcspan` $3) } objc_key_value_rlist :: { RevList ObjCDictElem } objc_key_value_rlist : objc_key_value { rsingleton $1 } | ANTI_OBJC_DICTS { rsingleton (AntiObjCDictElems (getANTI_OBJC_DICTS $1) (srclocOf $1)) } | objc_key_value_rlist ',' objc_key_value { rcons $3 $1 } objc_string_literal_rlist :: { RevList Const } objc_string_literal_rlist : '@' string_literal { rsingleton (mkStringConst $2) } | objc_string_literal_rlist '@' string_literal { rcons (mkStringConst $3) $1 } objc_selector_rlist :: { RevList Id } objc_selector_rlist : ':' { rsingleton (Id "" (srclocOf $1)) } | objc_selector ':' { rsingleton $1 } | objc_selector_rlist ':' { rcons (Id "" (srclocOf $2)) $1 } | objc_selector_rlist objc_selector ':' { rcons $2 $1 } -- Objective-C extension: at statement -- -- objc-at-statement -> -- '@' 'try' compound-statement objc-catch-statement+ -- | '@' 'try' compound-statement objc-catch-statement* '@' 'finally' compound-statement -- | '@' 'throw' [expression] ';' -- | '@' 'synchronized' '(' expression ')' compound-statement -- | '@' 'autoreleasepool' compound-statement -- -- objc-catch-statement -> -- '@' 'catch' '(' (parameter-declaration | '...') ')' compound-statement -- -- NB: If a try-catch statement without a finally clause is followed by another '@' statement, -- we require a ';' after the try-catch statement. To avoid that, we would need a lookahead -- of 2 (to see what special keyword comes after the '@'). In LALR(1), we get a shift-reduce -- conflict that shifts to continue the try-catch statement. -- objc_at_statement :: { Stm } objc_at_statement : '@' 'try' compound_statement objc_catch_statement_rlist '@' 'finally' compound_statement { let { tryItems = mkBlockItems $3 ; finallyItems = mkBlockItems $7 } in ObjCTry tryItems (rev $4) (Just finallyItems) ($1 `srcspan` $7) } | '@' 'try' compound_statement objc_catch_statement_rlist {% do { let { tryItems = mkBlockItems $3 ; catchStmts = rev $4 } ; when (null catchStmts) $ throw $ ParserException ($1 <--> $3) $ text "@try statement without @finally needs at least one @catch statement" ; return $ ObjCTry tryItems catchStmts Nothing ($1 `srcspan` catchStmts) } } | '@' 'try' compound_statement objc_catch_statement_rlist '@' error {% parserError ($1 <--> $5) (text $ "a @try-@catch statement without a @finally clause needs to be followed\n" ++ "by a semicolon if the next statement begins with a '@'") } | '@' 'throw' expression ';' { ObjCThrow (Just $3) ($1 `srcspan` $4) } | '@' 'throw' expression error {% expected ["';'"] Nothing } | '@' 'throw' ';' { ObjCThrow Nothing ($1 `srcspan` $3) } | '@' 'throw' error {% expected ["';'", "expression"] Nothing } | '@' 'synchronized' '(' expression ')' compound_statement { let items = mkBlockItems $6 in ObjCSynchronized $4 items ($1 `srcspan` $6) } | '@' 'autoreleasepool' compound_statement { let items = mkBlockItems $3 in ObjCAutoreleasepool items ($1 `srcspan` $3) } objc_catch_statement_rlist :: { RevList ObjCCatch } objc_catch_statement_rlist : {- empty -} { rnil } | objc_catch_statement_rlist '@' 'catch' '(' parameter_declaration ')' compound_statement { let items = mkBlockItems $7 in rcons (ObjCCatch (Just $5) items ($2 `srcspan` $7)) $1 } | objc_catch_statement_rlist '@' 'catch' '(' '...' ')' compound_statement { let items = mkBlockItems $7 in rcons (ObjCCatch Nothing items ($2 `srcspan` $7)) $1 } -- Objective-C extension: message expression -- -- objc-message-expr -> -- '[' objc-receiver -- ( objc-selector -- | ([objc-selector] ':' assignment-expression)+ (',' assignment-expression)* -- ) -- ']' -- -- objc-receiver -> 'super' | expression | class-name | type-name -- -- objc-selector is an identifier whose lexeme may also be that of the following keywords and type names: -- asm auto bool break case char const continue default do double else enum -- extern false float for goto if inline int long register restrict return -- short signed sizeof static struct switch true try typedef type name -- typeof union unsigned void volatile wchar_t while _Bool _Complex -- _Imaginary __alignof -- objc_message_expression :: { Exp } objc_message_expression : '[' objc_receiver objc_message_args ']' {% do { assertObjCEnabled ($1 <--> $4) "To use a message expression, enable Objective-C support" ; let (args, vargs) = $3 ; return $ ObjCMsg $2 args vargs ($1 `srcspan` $4) } } objc_receiver :: { ObjCRecv } objc_receiver : expression { case $1 of Var (Id "super" _) loc -> ObjCRecvSuper loc _ -> ObjCRecvExp $1 (srclocOf $1) } | ANTI_OBJC_RECV { AntiObjCRecv (getANTI_OBJC_RECV $1) (srclocOf $1) } objc_message_args :: { ([ObjCArg], [Exp]) } objc_message_args : objc_selector { ([ObjCArg (Just $1) Nothing (srclocOf $1)], []) } | objc_keywordarg_rlist objc_vararg_rlist { (rev $1, rev $2) } objc_selector :: { Id } objc_selector : identifier_or_typedef { $1 } -- | 'asm' { Id "asm" (srclocOf $1) } | 'auto' { Id "auto" (srclocOf $1) } -- | 'bool' { Id "bool" (srclocOf $1) } | 'break' { Id "break" (srclocOf $1) } | 'case' { Id "case" (srclocOf $1) } | 'char' { Id "char" (srclocOf $1) } | 'const' { Id "const" (srclocOf $1) } | 'continue' { Id "continue" (srclocOf $1) } | 'default' { Id "default" (srclocOf $1) } | 'do' { Id "do" (srclocOf $1) } | 'double' { Id "double" (srclocOf $1) } | 'else' { Id "else" (srclocOf $1) } | 'enum' { Id "enum" (srclocOf $1) } | 'extern' { Id "extern" (srclocOf $1) } -- | 'false' { Id "false" (srclocOf $1) } | 'float' { Id "float" (srclocOf $1) } | 'for' { Id "for" (srclocOf $1) } | 'goto' { Id "goto" (srclocOf $1) } | 'if' { Id "if" (srclocOf $1) } | 'inline' { Id "inline" (srclocOf $1) } | 'int' { Id "int" (srclocOf $1) } | 'long' { Id "long" (srclocOf $1) } | 'register' { Id "register" (srclocOf $1) } | 'restrict' { Id "restrict" (srclocOf $1) } | 'return' { Id "return" (srclocOf $1) } | 'short' { Id "short" (srclocOf $1) } | 'signed' { Id "signed" (srclocOf $1) } | 'sizeof' { Id "sizeof" (srclocOf $1) } | 'static' { Id "static" (srclocOf $1) } | 'struct' { Id "struct" (srclocOf $1) } | 'switch' { Id "switch" (srclocOf $1) } -- | 'true' { Id "true" (srclocOf $1) } -- | 'try' { Id "try" (srclocOf $1) } | 'typedef' { Id "typedef" (srclocOf $1) } | 'typename' { Id "typename" (srclocOf $1) } -- | 'typeof' { Id "typeof" (srclocOf $1) } | 'union' { Id "union" (srclocOf $1) } | 'unsigned' { Id "unsigned" (srclocOf $1) } | 'void' { Id "void" (srclocOf $1) } | 'volatile' { Id "volatile" (srclocOf $1) } -- | 'wchar_t' { Id "wchar_t" (srclocOf $1) } | 'while' { Id "while" (srclocOf $1) } -- | '_Bool' { Id "_Bool" (srclocOf $1) } -- | '_Complex' { Id "_Complex" (srclocOf $1) } -- | '_Imaginary' { Id "_Imaginary" (srclocOf $1) } | '__block' { Id "__block" (srclocOf $1) } | '__weak' { Id "__weak" (srclocOf $1) } | '__strong' { Id "__strong" (srclocOf $1) } | '__unsafe_unretained' { Id "__unsafe_unretained" (srclocOf $1) } -- | '__alignof' { Id "__alignof" (srclocOf $1) } objc_keywordarg_rlist :: { RevList ObjCArg } -- will be non-empty objc_keywordarg_rlist : objc_keywordarg { rsingleton $1 } | objc_keywordarg_rlist objc_keywordarg { $2 `rcons` $1 } | ANTI_OBJC_ARGS { rsingleton (AntiObjCArgs (getANTI_OBJC_ARGS $1) (srclocOf $1)) } objc_keywordarg :: { ObjCArg } objc_keywordarg : ':' assignment_expression { ObjCArg Nothing (Just $2) ($1 `srcspan` $2) } | objc_selector ':' assignment_expression { ObjCArg (Just $1) (Just $3) ($1 `srcspan` $3) } | ANTI_OBJC_ARG { AntiObjCArg (getANTI_OBJC_ARG $1) (srclocOf $1) } objc_vararg_rlist :: { RevList Exp } -- might be empty objc_vararg_rlist : {- empty -} { rnil } | objc_vararg_rlist ',' assignment_expression { $3 `rcons` $1 } | ANTI_ARGS { rsingleton (AntiArgs (getANTI_ARGS $1) (srclocOf $1)) } -- Objective-C extension: at expression -- -- objc-at-expression -> -- '@' ['+' | '-'] constant -- | '@' string-literal -- | '@' ('YES' | 'NO') -- | '@' '[' [assignment-expression (',' assignment-expression)* [',']] ']' -- | '@' '{' [objc-key-value (',' objc-key-value)* [',']] '}' -- | '@' '(' assignment-expression ')' -- | '@' 'encode' '(' type-name ')' -- | '@' 'protocol' '(' identifier ')' -- | '@' 'selector' '(' ( objc-selector | ([objc-selector] ':')+ ')' -- -- objc-key-value -> -- assignment-expression ':' assignment-expression -- -- NB: We need to make 'NO' and 'YES' into special tokens. If we match on "'@' identifier" instead, -- we get lots of shift-reduce conflicts as other special tokens that may appear behind a '@' -- can also reduce to "identifier". -- objc_at_expression :: { Exp } objc_at_expression : '@' constant { ObjCLitConst Nothing $2 ($1 `srcspan` $2) } | '@' '+' constant { ObjCLitConst (Just Positive) $3 ($1 `srcspan` $3) } | '@' '-' constant { ObjCLitConst (Just Negate) $3 ($1 `srcspan` $3) } | objc_string_literal_rlist { let lits = rev $1 in ObjCLitString lits (head lits `srcspan` last lits) } | '@' 'NO' { ObjCLitBool False ($1 `srcspan` $2) } | '@' 'YES' { ObjCLitBool True ($1 `srcspan` $2) } | '@' '[' ']' { ObjCLitArray [] ($1 `srcspan` $3) } | '@' '[' assignment_expression_list ']' { ObjCLitArray $3 ($1 `srcspan` $4) } | '@' lbrace '}' { ObjCLitDict [] ($1 `srcspan` $3) } | '@' lbrace objc_key_value_rlist '}' { ObjCLitDict (rev $3) ($1 `srcspan` $4) } | '@' lbrace objc_key_value_rlist ',' '}' { ObjCLitDict (rev $3) ($1 `srcspan` $5) } | '@' '(' expression ')' { ObjCLitBoxed $3 ($1 `srcspan` $4) } | '@' 'encode' '(' type_name ')' { ObjCEncode $4 ($1 `srcspan` $5) } | '@' 'protocol' '(' identifier ')' { ObjCProtocol $4 ($1 `srcspan` $5) } | '@' 'selector' '(' objc_selector ')' { let Id str _ = $4 in ObjCSelector str ($1 `srcspan` $5) } | '@' 'selector' '(' objc_selector_rlist ')' { let str = concat [s ++ ":" | Id s _ <- rev $4] in ObjCSelector str ($1 `srcspan` $5) } -- Objective-C extension: class declaration -- -- objc-class-declaration -> -- '@' 'class' identifier+ ';' -- objc_class_declaration :: { Definition } objc_class_declaration : '@' 'class' identifier_rlist semi {% do { let idents = rev $3 ; mapM addClassdefId idents ; return $ ObjCClassDec idents ($1 `srcspan` $4) } } -- Objective-C extension: class or category interface -- -- objc-interface -> -- [attribute_specifiers] objc-class-interface | objc-category-interface -- -- objc-class-interface -> -- '@' 'interface' identifier [':' identifier] -- [objc-protocol-refs] -- [objc-class-instance-variables] -- objc-interface-decl* -- '@' 'end' -- -- objc-category-interface -> -- '@' 'interface' identifier '(' [identifier] ')' -- [objc-protocol-refs] -- [objc-class-instance-variables] -- objc-interface-decl* -- '@' 'end' -- -- objc-protocol-refs -> -- '<' identifier-list '>' -- -- objc-class-instance-variables -> -- '{' objc-instance-variable-decl* '}' -- -- objc-instance-variable-decl -> -- objc-visibility-spec | [objc-instance-variable-decl] ';' -- -- objc-instance-variable-decl -> struct-declaration -- -- objc-visibility-spec -> '@' 'private' | '@' 'public' | '@' 'protected' | '@' 'package' -- -- objc-interface-decl -> -- objc-property-decl | objc-method-requirement | objc-method-proto ';' | declaration | ';' -- -- objc-property-decl -> -- '@' 'property' [objc-property-attrs] struct-declaration ';' -- -- objc-property-attrs -> -- '(' objc-property-attribute (',' objc-property-attribute)* ')' -- -- objc-property-attribute -> -- 'getter' '=' objc-selector -- | 'setter' '=' objc-selector ':' -- | 'readonly' -- | 'readwrite' -- | 'assign' -- | 'retain' -- | 'copy' -- | 'nonatomic' -- | 'atomic' -- | 'strong' -- | 'weak' -- | 'unsafe_unretained' -- -- objc-method-requirement -> '@' 'required' | '@' 'optional' -- -- objc-method-proto -> -- ('-' | '+') objc-method-decl [attribute_specifiers] -- -- objc-method-decl -> -- ['(' type-name ')'] [attribute_specifiers] -- ( objc-selector -- | ([objc-selector] ':' ['(' type-name ')'] [attribute_specifiers] identifier)+ -- ) [',' '...'] -- -- NB: We omit C-style parameters to methods as they don't appear to be current anymore. -- -- To avoid a reduce/reduce conflict, we parse the attributes that can appear -- before an interface declaration using the storage_qualifier_specifiers -- non-terminal and check it for non-attributes in the body of the production. objc_interface :: { Definition } objc_interface : '@' 'interface' identifier objc_interface_body {% do { let (prot, vars, decls, loc) = $4 ; addClassdefId $3 ; return $ ObjCClassIface $3 Nothing prot vars decls [] ($1 `srcspan` loc) } } | storage_qualifier_specifiers '@' 'interface' identifier objc_interface_body {% do { let (prot, vars, decls, loc) = $5 ; addClassdefId $4 ; attrs <- checkOnlyAttributes $1 ; return $ ObjCClassIface $4 Nothing prot vars decls attrs ($2 `srcspan` loc) } } | '@' 'interface' identifier ':' identifier_or_typedef objc_interface_body {% do { let (prot, vars, decls, loc) = $6 ; addClassdefId $3 ; return $ ObjCClassIface $3 (Just $5) prot vars decls [] ($1 `srcspan` loc) } } | storage_qualifier_specifiers '@' 'interface' identifier ':' identifier_or_typedef objc_interface_body {% do { let (prot, vars, decls, loc) = $7 ; addClassdefId $4 ; attrs <- checkOnlyAttributes $1 ; return $ ObjCClassIface $4 (Just $6) prot vars decls attrs ($2 `srcspan` loc) } } | '@' 'interface' identifier_or_typedef '(' ')' objc_interface_body { let (prot, vars, decls, loc) = $6 in ObjCCatIface $3 Nothing prot vars decls ($1 `srcspan` loc) } | '@' 'interface' identifier_or_typedef '(' identifier ')' objc_interface_body { let (prot, vars, decls, loc) = $7 in ObjCCatIface $3 (Just $5) prot vars decls ($1 `srcspan` loc) } objc_interface_body :: { ([Id], [ObjCIvarDecl], [ObjCIfaceDecl], Loc) } objc_interface_body : objc_protocol_refs_rlist objc_class_instance_variables_rlist objc_interface_decl_rlist '@' 'end' { ( rev $1, rev $2, rev $3, $4 <--> $5) } objc_protocol_refs_rlist :: { RevList Id } objc_protocol_refs_rlist : {- empty -} { rnil } | '<' identifier_rlist '>' { $2 } objc_class_instance_variables_rlist :: { RevList ObjCIvarDecl } objc_class_instance_variables_rlist : {- empty -} { rnil } | lbrace '}' { rnil } | lbrace objc_instance_variable_decl_rlist '}' { $2 } objc_instance_variable_decl_rlist :: { RevList ObjCIvarDecl } objc_instance_variable_decl_rlist : objc_visibility_spec { rsingleton (ObjCIvarVisi $1 (srclocOf $1)) } | semi { rnil } | struct_declaration semi { rsingleton (ObjCIvarDecl $1 (srclocOf $1)) } | objc_instance_variable_decl_rlist objc_visibility_spec { rcons (ObjCIvarVisi $2 (srclocOf $2)) $1 } | objc_instance_variable_decl_rlist semi { $1 } | objc_instance_variable_decl_rlist struct_declaration semi { rcons (ObjCIvarDecl $2 (srclocOf $2)) $1 } objc_visibility_spec :: { ObjCVisibilitySpec } objc_visibility_spec : '@' 'objc_private' { ObjCPrivate ($1 `srcspan` $2) } | '@' 'public' { ObjCPublic ($1 `srcspan` $2) } | '@' 'protected' { ObjCProtected ($1 `srcspan` $2) } | '@' 'package' { ObjCPackage ($1 `srcspan` $2) } objc_interface_decl_list :: { [ObjCIfaceDecl] } objc_interface_decl_list : objc_interface_decl_rlist { rev $1 } objc_interface_decl_rlist :: { RevList ObjCIfaceDecl } objc_interface_decl_rlist : {- empty -} { rnil } | objc_interface_decl_rlist semi { $1 } | objc_interface_decl_rlist objc_interface_decl { rcons $2 $1 } | objc_interface_decl_rlist ANTI_OBJC_IFDECLS { rcons (AntiObjCIfaceDecls (getANTI_OBJC_IFDECLS $2) (srclocOf $2)) $1 } | objc_interface_decl_rlist ANTI_OBJC_PROPS { rcons (AntiObjCProps (getANTI_OBJC_PROPS $2) (srclocOf $2)) $1 } objc_interface_decl :: { ObjCIfaceDecl } objc_interface_decl : objc_property_decl { $1 } | objc_method_requirement { ObjCIfaceReq $1 (srclocOf $1) } | objc_method_proto semi { ObjCIfaceMeth $1 (srclocOf $1) } | declaration { ObjCIfaceDecl $1 (srclocOf $1) } | ANTI_OBJC_IFDECL { AntiObjCIfaceDecl (getANTI_OBJC_IFDECL $1) (srclocOf $1) } objc_property_decl :: { ObjCIfaceDecl } objc_property_decl : '@' 'property' struct_declaration { ObjCIfaceProp [] $3 ($1 `srcspan` $3) } | '@' 'property' '(' objc_property_attr_rlist ')' struct_declaration { ObjCIfaceProp (rev $4) $6 ($1 `srcspan` $6) } | ANTI_OBJC_PROP { AntiObjCProp (getANTI_OBJC_PROP $1) (srclocOf $1) } objc_property_attr_rlist :: { RevList ObjCPropAttr } objc_property_attr_rlist : objc_property_attr { rsingleton $1 } | objc_property_attr_rlist ',' objc_property_attr { rcons $3 $1 } | ANTI_OBJC_PROP_ATTRS { rsingleton (AntiObjCAttrs (getANTI_OBJC_PROP_ATTRS $1) (srclocOf $1)) } objc_property_attr :: { ObjCPropAttr } objc_property_attr : identifier '=' objc_selector {% case $1 of { Id "getter" _ -> return $ ObjCGetter $3 ($1 `srcspan` $3) ; _ -> expectedObjCPropertyAttr (locOf $1) } } | identifier '=' objc_selector ':' {% case $1 of { Id "setter" _ -> return $ ObjCSetter $3 ($1 `srcspan` $4) ; _ -> expectedObjCPropertyAttr (locOf $1) } } | identifier {% case $1 of { Id "readonly" _ -> return $ ObjCReadonly (srclocOf $1) ; Id "readwrite" _ -> return $ ObjCReadwrite (srclocOf $1) ; Id "assign" _ -> return $ ObjCAssign (srclocOf $1) ; Id "retain" _ -> return $ ObjCRetain (srclocOf $1) ; Id "copy" _ -> return $ ObjCCopy (srclocOf $1) ; Id "nonatomic" _ -> return $ ObjCNonatomic (srclocOf $1) ; Id "atomic" _ -> return $ ObjCAtomic (srclocOf $1) ; Id "strong" _ -> return $ ObjCStrong (srclocOf $1) ; Id "weak" _ -> return $ ObjCWeak (srclocOf $1) ; Id "unsafe_unretained" _ -> return $ ObjCUnsafeUnretained (srclocOf $1) ; _ -> expectedObjCPropertyAttr (locOf $1) } } | ANTI_OBJC_PROP_ATTR { AntiObjCAttr (getANTI_OBJC_PROP_ATTR $1) (srclocOf $1) } objc_method_requirement :: { ObjCMethodReq } objc_method_requirement : '@' 'required' { ObjCRequired ($1 `srcspan` $2) } | '@' 'optional' { ObjCOptional ($1 `srcspan` $2) } objc_method_proto :: { ObjCMethodProto } objc_method_proto : '-' objc_method_decl attribute_specifiers_opt { let (res, attrs, params, hasVargs) = $2 in ObjCMethodProto False res attrs params hasVargs $3 ($1 `srcspan` $3) } | '+' objc_method_decl attribute_specifiers_opt { let (res, attrs, params, hasVargs) = $2 in ObjCMethodProto True res attrs params hasVargs $3 ($1 `srcspan` $3) } | ANTI_OBJC_METHOD_PROTO { AntiObjCMethodProto (getANTI_OBJC_METHOD_PROTO $1) (srclocOf $1) } objc_method_decl :: { (Maybe Type, [Attr], [ObjCParam], Bool) } objc_method_decl : attribute_specifiers_opt objc_method_params { (Nothing, $1, $2, False) } | '(' type_name ')' attribute_specifiers_opt objc_method_params { (Just $2, $4, $5, False) } | attribute_specifiers_opt objc_method_params ',' '...' { (Nothing, $1, $2, True) } | '(' type_name ')' attribute_specifiers_opt objc_method_params ',' '...' { (Just $2, $4, $5, True) } objc_method_params :: { [ObjCParam] } objc_method_params : objc_selector { [ObjCParam (Just $1) Nothing [] Nothing (srclocOf $1)] } | objc_method_param_rlist { rev $1 } objc_method_param_rlist :: { RevList ObjCParam } objc_method_param_rlist : objc_method_param { rsingleton $1 } | objc_method_param_rlist objc_method_param { rcons $2 $1 } | ANTI_OBJC_PARAMS { rsingleton (AntiObjCParams (getANTI_OBJC_PARAMS $1) (srclocOf $1)) } objc_method_param :: { ObjCParam } objc_method_param : objc_selector ':' '(' type_name ')' attribute_specifiers_opt identifier { ObjCParam (Just $1) (Just $4) $6 (Just $7) ($1 `srcspan` $7) } | ':' '(' type_name ')' attribute_specifiers_opt identifier { ObjCParam Nothing (Just $3) $5 (Just $6) ($1 `srcspan` $6) } | objc_selector ':' attribute_specifiers_opt identifier { ObjCParam (Just $1) Nothing $3 (Just $4) ($1 `srcspan` $4) } | ':' attribute_specifiers_opt identifier { ObjCParam Nothing Nothing $2 (Just $3) ($1 `srcspan` $3) } | ANTI_OBJC_PARAM { AntiObjCParam (getANTI_OBJC_PARAM $1) (srclocOf $1) } -- Objective-C extension: protocol declaration -- -- objc-protocol-declaration -> -- objc-protocol-definition | objc-protocol-forward-reference -- -- objc-protocol-definition -> -- '@' 'protocol' identifier -- [objc-protocol-refs] -- objc-interface-decl* -- '@' 'end' -- -- objc-protocol-forward-reference -> -- '@' 'protocol' identifier-list ';' -- -- NB: "@protocol identifier ;" should be parsed as a 'objc-protocol-forward-reference', which means that -- 'objc-interface-decl-list' in 'objc-protocol-definition' may not start with a semicolon if the -- 'objc-protocol-refs' are empty. -- -- We achieve this by factoring the common prefix into the non-terminal 'objc_protocol_prefix' to turn -- the ambiguity into a shift-reduce conflict that is resolved by preferring shifting. -- objc_protocol_declaration :: { Definition } objc_protocol_declaration : objc_protocol_prefix objc_protocol_refs_rlist objc_interface_decl_rlist '@' 'end' { ObjCProtDef (fst $1) (rev $2) (rev $3) (snd $1 `srcspan` $5) } -- This rule wins the shift-reduce conflict | objc_protocol_prefix semi { ObjCProtDec [fst $1] (snd $1 `srcspan` $2) } | objc_protocol_prefix ',' identifier_rlist semi { ObjCProtDec (fst $1 : rev $3) (snd $1 `srcspan` $4) } objc_protocol_prefix :: { (Id, Loc) } objc_protocol_prefix : '@' 'protocol' identifier { ($3, locOf $1) } -- Objective-C extension: class or category implementation -- -- objc-implementation -> -- objc-class-implementation | objc-category-implementation -- -- objc-class-implementation -> -- '@' 'implementation' identifier [':' identifier] -- [objc-class-instance-variables] -- objc-implementation-decl* -- '@' end -- -- objc-category-implementation -> -- '@' 'implementation' identifier '(' identifier ')' -- objc-implementation-decl* -- '@' end -- -- objc-implementation-decl -> -- function-definition | declaration | property-synthesize | property-dynamic | objc-method-definition -- -- property-synthesize -> -- '@' 'synthesize' property-ivar (',' property-ivar)* ';' -- -- property-dynamic -> -- '@' 'dynamic' identifier (',' identifier)* ';' -- -- property-ivar -> -- identifier | identifier '=' identifier -- -- objc-method-definition -> -- objc-method-proto [';'] compound_statement -- objc_implementation :: { Definition } objc_implementation : '@' 'implementation' identifier_or_typedef ':' identifier_or_typedef objc_implementation_body_vars { let (ivars, defs, loc) = $6 in ObjCClassImpl $3 (Just $5) ivars defs ($1 `srcspan` loc) } | '@' 'implementation' identifier_or_typedef objc_implementation_body_vars { let (ivars, defs, loc) = $4 in ObjCClassImpl $3 Nothing ivars defs ($1 `srcspan` loc) } | '@' 'implementation' identifier_or_typedef '(' identifier ')' objc_implementation_body { ObjCCatImpl $3 $5 (fst $7) ($1 `srcspan` snd $7) } objc_implementation_body_vars :: { ([ObjCIvarDecl], [Definition], Loc) } objc_implementation_body_vars : objc_class_instance_variables_rlist objc_implementation_body { (rev $1, fst $2, snd $2) } objc_implementation_body :: { ([Definition], Loc) } objc_implementation_body : objc_implementation_decl_rlist '@' 'end' { (rev $1, locOf $3) } objc_implementation_decl_list :: { [Definition] } objc_implementation_decl_list : objc_implementation_decl_rlist { rev $1 } objc_implementation_decl_rlist :: { RevList Definition } objc_implementation_decl_rlist : {- empty -} { rnil } | objc_implementation_decl_rlist function_definition { rcons (FuncDef $2 (srclocOf $2)) $1 } | objc_implementation_decl_rlist declaration { rcons (DecDef $2 (srclocOf $2)) $1 } | objc_implementation_decl_rlist property_synthesize { rcons $2 $1 } | objc_implementation_decl_rlist property_dynamic { rcons $2 $1 } | objc_implementation_decl_rlist objc_method_definition { rcons $2 $1 } | objc_implementation_decl_rlist ANTI_FUNC { rcons (AntiFunc (getANTI_FUNC $2) (srclocOf $2)) $1 } | objc_implementation_decl_rlist ANTI_ESC { rcons (AntiEsc (getANTI_ESC $2) (srclocOf $2)) $1 } | objc_implementation_decl_rlist ANTI_EDECL { rcons (AntiEdecls (getANTI_EDECL $2) (srclocOf $2)) $1 } | objc_implementation_decl_rlist ANTI_EDECLS { rcons (AntiEdecls (getANTI_EDECLS $2) (srclocOf $2)) $1 } property_synthesize :: { Definition } property_synthesize : '@' 'synthesize' property_ivar_rlist semi { ObjCSynDef (rev $3) ($1 `srcspan` $4) } property_ivar_rlist :: { RevList (Id, Maybe Id) } property_ivar_rlist : identifier { rsingleton ($1, Nothing) } | identifier '=' identifier { rsingleton ($1, Just $3) } | property_ivar_rlist identifier { rcons ($2, Nothing) $1 } | property_ivar_rlist identifier '=' identifier { rcons ($2, Just $4) $1 } property_dynamic :: { Definition } property_dynamic : '@' 'dynamic' identifier_rlist semi { ObjCDynDef (rev $3) ($1 `srcspan` $4) } objc_method_definition :: { Definition } objc_method_definition : objc_method_proto semi compound_statement { let stmts = mkBlockItems $3 in ObjCMethDef $1 stmts ($1 `srcspan` $3) } | objc_method_proto compound_statement { let stmts = mkBlockItems $2 in ObjCMethDef $1 stmts ($1 `srcspan` $2) } | ANTI_OBJC_METHOD_DEF { AntiObjCMeth (getANTI_OBJC_METHOD_DEF $1) (srclocOf $1) } | ANTI_OBJC_METHOD_DEFS { AntiObjCMeths (getANTI_OBJC_METHOD_DEFS $1) (srclocOf $1) } -- Objective-C extension: compatibility alias -- -- objc-compatibility-alias -> -- '@' 'compatibility_alias' identifier class-name ';' -- objc_compatibility_alias :: { Definition } objc_compatibility_alias : '@' 'compatibility_alias' identifier OBJCNAMED semi {% do { addClassdefId $3 ; return $ ObjCCompAlias $3 (Id (getOBJCNAMED $1) (srclocOf $1)) ($1 `srcspan` $5) } } {------------------------------------------------------------------------------ - - CUDA - ------------------------------------------------------------------------------} cuda_lambda_expression :: { Exp } cuda_lambda_expression : cuda_lambda_introducer cuda_lambda_declarator compound_statement {% do { assertCudaEnabled ($1 <--> $3) "To use lambda-expressions, enable support for CUDA" ; let items = mkBlockItems $3 ; return $ Lambda $1 $2 items ($1 `srcspan` $3) } } cuda_lambda_declarator :: { Maybe LambdaDeclarator } cuda_lambda_declarator : cuda_lambda_param_list cuda_lambda_mutable cuda_lambda_return_type { Just $ LambdaDeclarator $1 $2 $3 ($1 `srcspan` $3) } | {- empty -} { Nothing } cuda_lambda_param_list :: { Params } cuda_lambda_param_list : '(' ')' { Params [] False ($1 `srcspan` $2) } | '(' parameter_type_list ')' { $2 } cuda_lambda_mutable :: { Bool } cuda_lambda_mutable : 'mutable' { True } | {- Empty -} { False } cuda_lambda_return_type :: { Maybe Type } cuda_lambda_return_type : {- Empty -} { Nothing } -- FIXME: There should be possibility to explicitly state returned type. -- | '->' type_name { Just ($2::Type) } cuda_lambda_introducer :: { LambdaIntroducer } cuda_lambda_introducer : '[' cuda_lambda_capture_items ']' { LambdaIntroducer $2 ($1 `srcspan` $3)} cuda_lambda_capture_items :: { [CaptureListEntry] } cuda_lambda_capture_items : '&' { [DefaultByReference] } | '=' { [DefaultByValue] } | {- empty -} { [] } execution_configuration :: { ExeConfig } execution_configuration : argument_expression_list {%do { let args = $1 ; when (length args < 2 || length args > 4) $ do parserError (locOf args) $ text "execution context should have 2-4 arguments, but saw" <+> ppr (length args) ; return $ case args of { [gridDim, blockDim] -> ExeConfig gridDim blockDim Nothing Nothing (srclocOf args) ; [gridDim, blockDim, sharedSize] -> ExeConfig gridDim blockDim (Just sharedSize) Nothing (srclocOf args) ; [gridDim, blockDim, sharedSize, exeStream] -> ExeConfig gridDim blockDim (Just sharedSize) (Just exeStream) (srclocOf args) } } } { happyError :: L T.Token -> P a happyError (L loc t) = parserError (locStart loc) (text "parse error on" <+> quoteTok (ppr t)) getCHAR (L _ (T.TcharConst x)) = x getSTRING (L _ (T.TstringConst x)) = x getINT (L _ (T.TintConst x)) = x getLONG (L _ (T.TlongIntConst x)) = x getLONG_LONG (L _ (T.TlongLongIntConst x)) = x getFLOAT (L _ (T.TfloatConst x)) = x getDOUBLE (L _ (T.TdoubleConst x)) = x getLONG_DOUBLE (L _ (T.TlongDoubleConst x)) = x getID (L _ (T.Tidentifier ident)) = ident getNAMED (L _ (T.Tnamed ident)) = ident getOBJCNAMED (L _ (T.TObjCnamed ident)) = ident getPRAGMA (L _ (T.Tpragma pragma)) = pragma getCOMMENT (L _ (T.Tcomment comment)) = comment getANTI_ID (L _ (T.Tanti_id v)) = v getANTI_CONST (L _ (T.Tanti_const v)) = v getANTI_INT (L _ (T.Tanti_int v)) = v getANTI_UINT (L _ (T.Tanti_uint v)) = v getANTI_LINT (L _ (T.Tanti_lint v)) = v getANTI_ULINT (L _ (T.Tanti_ulint v)) = v getANTI_LLINT (L _ (T.Tanti_llint v)) = v getANTI_ULLINT (L _ (T.Tanti_ullint v)) = v getANTI_FLOAT (L _ (T.Tanti_float v)) = v getANTI_DOUBLE (L _ (T.Tanti_double v)) = v getANTI_LONG_DOUBLE (L _ (T.Tanti_long_double v)) = v getANTI_CHAR (L _ (T.Tanti_char v)) = v getANTI_STRING (L _ (T.Tanti_string v)) = v getANTI_EXP (L _ (T.Tanti_exp v)) = v getANTI_FUNC (L _ (T.Tanti_func v)) = v getANTI_ARGS (L _ (T.Tanti_args v)) = v getANTI_DECL (L _ (T.Tanti_decl v)) = v getANTI_DECLS (L _ (T.Tanti_decls v)) = v getANTI_SDECL (L _ (T.Tanti_sdecl v)) = v getANTI_SDECLS (L _ (T.Tanti_sdecls v)) = v getANTI_ENUM (L _ (T.Tanti_enum v)) = v getANTI_ENUMS (L _ (T.Tanti_enums v)) = v getANTI_ESC (L _ (T.Tanti_esc v)) = v getANTI_ESCSTM (L _ (T.Tanti_escstm v)) = v getANTI_EDECL (L _ (T.Tanti_edecl v)) = v getANTI_EDECLS (L _ (T.Tanti_edecls v)) = v getANTI_ITEM (L _ (T.Tanti_item v)) = v getANTI_ITEMS (L _ (T.Tanti_items v)) = v getANTI_STM (L _ (T.Tanti_stm v)) = v getANTI_STMS (L _ (T.Tanti_stms v)) = v getANTI_TYPE_QUAL (L _ (T.Tanti_type_qual v)) = v getANTI_TYPE_QUALS (L _ (T.Tanti_type_quals v)) = v getANTI_TYPE (L _ (T.Tanti_type v)) = v getANTI_SPEC (L _ (T.Tanti_spec v)) = v getANTI_PARAM (L _ (T.Tanti_param v)) = v getANTI_PARAMS (L _ (T.Tanti_params v)) = v getANTI_PRAGMA (L _ (T.Tanti_pragma v)) = v getANTI_COMMENT (L _ (T.Tanti_comment v)) = v getANTI_INIT (L _ (T.Tanti_init v)) = v getANTI_INITS (L _ (T.Tanti_inits v)) = v getANTI_ATTR (L _ (T.Tanti_attr v)) = v getANTI_ATTRS (L _ (T.Tanti_attrs v)) = v -- -- Objective-C -- getANTI_OBJC_IFDECL (L _ (T.Tanti_objc_ifdecl v)) = v getANTI_OBJC_IFDECLS (L _ (T.Tanti_objc_ifdecls v)) = v getANTI_OBJC_PROP (L _ (T.Tanti_objc_prop v)) = v getANTI_OBJC_PROPS (L _ (T.Tanti_objc_props v)) = v getANTI_OBJC_PROP_ATTR (L _ (T.Tanti_objc_prop_attr v)) = v getANTI_OBJC_PROP_ATTRS (L _ (T.Tanti_objc_prop_attrs v)) = v getANTI_OBJC_DICTS (L _ (T.Tanti_objc_dicts v)) = v getANTI_OBJC_PARAM (L _ (T.Tanti_objc_param v)) = v getANTI_OBJC_PARAMS (L _ (T.Tanti_objc_params v)) = v getANTI_OBJC_METHOD_PROTO (L _ (T.Tanti_objc_method_proto v)) = v getANTI_OBJC_METHOD_DEF (L _ (T.Tanti_objc_method_def v)) = v getANTI_OBJC_METHOD_DEFS (L _ (T.Tanti_objc_method_defs v)) = v getANTI_OBJC_RECV (L _ (T.Tanti_objc_recv v)) = v getANTI_OBJC_ARG (L _ (T.Tanti_objc_arg v)) = v getANTI_OBJC_ARGS (L _ (T.Tanti_objc_args v)) = v lexer :: (L T.Token -> P a) -> P a lexer cont = do t <- lexToken setCurToken t cont t locate :: Loc -> (SrcLoc -> a) -> L a locate loc f = L loc (f (SrcLoc loc)) data TySpec = TSauto !SrcLoc | TSregister !SrcLoc | TSstatic !SrcLoc | TSextern (Maybe Linkage) !SrcLoc | TStypedef !SrcLoc | TSconst !SrcLoc | TSvolatile !SrcLoc | TSsigned !SrcLoc | TSunsigned !SrcLoc | TSvoid !SrcLoc | TSchar !SrcLoc | TSshort !SrcLoc | TSlong !SrcLoc | TSint !SrcLoc | TSfloat !SrcLoc | TSdouble !SrcLoc | TSstruct (Maybe Id) (Maybe [FieldGroup]) [Attr] !SrcLoc | TSunion (Maybe Id) (Maybe [FieldGroup]) [Attr] !SrcLoc | TSenum (Maybe Id) [CEnum] [Attr] !SrcLoc | TSnamed Id [Id] !SrcLoc -- the '[Id]' are Objective-C protocol references | TSAntiTypeQual String !SrcLoc | TSAntiTypeQuals String !SrcLoc -- C99 | TS_Bool !SrcLoc | TS_Complex !SrcLoc | TS_Imaginary !SrcLoc | TSinline !SrcLoc | TSrestrict !SrcLoc -- GCC | TStypeofExp Exp !SrcLoc | TStypeofType Type !SrcLoc | TSva_list !SrcLoc | TSAttr Attr | TS__restrict !SrcLoc -- Clang blocks | TS__block !SrcLoc -- Objective-C | TSObjC__weak !SrcLoc | TSObjC__strong !SrcLoc | TSObjC__unsafe_unretained !SrcLoc -- CUDA | TSCUDAdevice !SrcLoc | TSCUDAglobal !SrcLoc | TSCUDAhost !SrcLoc | TSCUDAconstant !SrcLoc | TSCUDAshared !SrcLoc | TSCUDArestrict !SrcLoc | TSCUDAnoinline !SrcLoc -- OpenCL | TSCLprivate !SrcLoc | TSCLlocal !SrcLoc | TSCLglobal !SrcLoc | TSCLconstant !SrcLoc | TSCLreadonly !SrcLoc | TSCLwriteonly !SrcLoc | TSCLkernel !SrcLoc deriving (Eq, Ord, Show) instance Located TySpec where locOf (TSauto loc) = locOf loc locOf (TSregister loc) = locOf loc locOf (TSstatic loc) = locOf loc locOf (TSextern _ loc) = locOf loc locOf (TStypedef loc) = locOf loc locOf (TSconst loc) = locOf loc locOf (TSvolatile loc) = locOf loc locOf (TSsigned loc) = locOf loc locOf (TSunsigned loc) = locOf loc locOf (TSvoid loc) = locOf loc locOf (TSchar loc) = locOf loc locOf (TSshort loc) = locOf loc locOf (TSint loc) = locOf loc locOf (TSlong loc) = locOf loc locOf (TSfloat loc) = locOf loc locOf (TSdouble loc) = locOf loc locOf (TSstruct _ _ _ loc) = locOf loc locOf (TSunion _ _ _ loc) = locOf loc locOf (TSenum _ _ _ loc) = locOf loc locOf (TSnamed _ _ loc) = locOf loc locOf (TSAntiTypeQual _ loc) = locOf loc locOf (TSAntiTypeQuals _ loc) = locOf loc locOf (TS_Bool loc) = locOf loc locOf (TS_Complex loc) = locOf loc locOf (TS_Imaginary loc) = locOf loc locOf (TSinline loc) = locOf loc locOf (TSrestrict loc) = locOf loc locOf (TStypeofExp _ loc) = locOf loc locOf (TStypeofType _ loc) = locOf loc locOf (TSva_list loc) = locOf loc locOf (TSAttr attr) = locOf attr locOf (TS__restrict loc) = locOf loc locOf (TS__block loc) = locOf loc locOf (TSObjC__weak loc) = locOf loc locOf (TSObjC__strong loc) = locOf loc locOf (TSObjC__unsafe_unretained loc) = locOf loc locOf (TSCUDAdevice loc) = locOf loc locOf (TSCUDAglobal loc) = locOf loc locOf (TSCUDAhost loc) = locOf loc locOf (TSCUDAconstant loc) = locOf loc locOf (TSCUDAshared loc) = locOf loc locOf (TSCUDArestrict loc) = locOf loc locOf (TSCUDAnoinline loc) = locOf loc locOf (TSCLprivate loc) = locOf loc locOf (TSCLlocal loc) = locOf loc locOf (TSCLglobal loc) = locOf loc locOf (TSCLconstant loc) = locOf loc locOf (TSCLreadonly loc) = locOf loc locOf (TSCLwriteonly loc) = locOf loc locOf (TSCLkernel loc) = locOf loc instance Pretty TySpec where ppr (TSauto _) = text "auto" ppr (TSregister _) = text "register" ppr (TSstatic _) = text "static" ppr (TSextern Nothing _) = text "extern" ppr (TSextern (Just l) _) = text "extern" <+> ppr l ppr (TStypedef _) = text "typedef" ppr (TSconst _) = text "const" ppr (TSvolatile _) = text "volatile" ppr (TSsigned _) = text "signed" ppr (TSunsigned _) = text "unsigned" ppr (TSvoid _) = text "void" ppr (TSchar _) = text "char" ppr (TSshort _) = text "short" ppr (TSint _) = text "int" ppr (TSlong _) = text "long" ppr (TSfloat _) = text "float" ppr (TSdouble _) = text "double" ppr (TSstruct maybe_id maybe_fields attrs _) = pprStructOrUnion "struct" maybe_id maybe_fields attrs ppr (TSunion maybe_id maybe_fields attrs _) = pprStructOrUnion "union" maybe_id maybe_fields attrs ppr (TSenum maybe_id cenums attrs _) = pprEnum maybe_id cenums attrs ppr (TSnamed ident ps _) = ppr ident <> if null ps then empty else angles (commasep (map ppr ps)) ppr (TS_Bool _) = text "_Bool" ppr (TS_Complex _) = text "_Complex" ppr (TS_Imaginary _) = text "_Imaginary" ppr (TSinline _) = text "inline" ppr (TSrestrict _) = text "restrict" ppr (TStypeofExp e _) = text "__typeof__" <> parens (ppr e) ppr (TStypeofType ty _) = text "__typeof__" <> parens (ppr ty) ppr (TSva_list _) = text "__builtin_va_list" ppr (TSAttr attr) = ppr [attr] ppr (TS__restrict _) = text "__restrict" ppr (TS__block _) = text "__block" ppr (TSObjC__weak _) = text "__weak" ppr (TSObjC__strong _) = text "__strong" ppr (TSObjC__unsafe_unretained _) = text "__unsafe_unretained" ppr (TSCUDAdevice _) = text "__device__" ppr (TSCUDAglobal _) = text "__global__" ppr (TSCUDAhost _) = text "__host__" ppr (TSCUDAconstant _) = text "__constant__" ppr (TSCUDAshared _) = text "__shared__" ppr (TSCUDArestrict _) = text "__restrict__" ppr (TSCUDAnoinline _) = text "__noinline__" ppr (TSCLprivate _) = text "__private" ppr (TSCLlocal _) = text "__local" ppr (TSCLglobal _) = text "__global" ppr (TSCLconstant _) = text "__constant" ppr (TSCLreadonly _) = text "read_only" ppr (TSCLwriteonly _) = text "write_only" ppr (TSCLkernel _) = text "__kernel" isStorage :: TySpec -> Bool isStorage (TSauto _) = True isStorage (TSregister _) = True isStorage (TSstatic _) = True isStorage (TSextern _ _) = True isStorage (TStypedef _) = True isStorage (TS__block _) = True isStorage (TSObjC__weak _) = True isStorage (TSObjC__strong _) = True isStorage (TSObjC__unsafe_unretained _) = True isStorage _ = False mkStorage :: [TySpec] -> [Storage] mkStorage specs = map mk (filter isStorage specs) where mk :: TySpec -> Storage mk (TSauto loc) = Tauto loc mk (TSregister loc) = Tregister loc mk (TSstatic loc) = Tstatic loc mk (TSextern l loc) = Textern l loc mk (TStypedef loc) = Ttypedef loc mk (TS__block loc) = T__block loc mk (TSObjC__weak loc) = TObjC__weak loc mk (TSObjC__strong loc) = TObjC__strong loc mk (TSObjC__unsafe_unretained loc) = TObjC__unsafe_unretained loc mk _ = error "internal error in mkStorage" isTypeQual :: TySpec -> Bool isTypeQual (TSconst _) = True isTypeQual (TSvolatile _) = True isTypeQual (TSAntiTypeQual {}) = True isTypeQual (TSAntiTypeQuals {}) = True isTypeQual (TSinline _) = True isTypeQual (TSrestrict _) = True isTypeQual (TSAttr _) = True isTypeQual (TS__restrict _) = True isTypeQual (TSCUDAdevice _) = True isTypeQual (TSCUDAglobal _) = True isTypeQual (TSCUDAhost _) = True isTypeQual (TSCUDAconstant _) = True isTypeQual (TSCUDAshared _) = True isTypeQual (TSCUDArestrict _) = True isTypeQual (TSCUDAnoinline _) = True isTypeQual (TSCLprivate _) = True isTypeQual (TSCLlocal _) = True isTypeQual (TSCLglobal _) = True isTypeQual (TSCLconstant _) = True isTypeQual (TSCLreadonly _) = True isTypeQual (TSCLwriteonly _) = True isTypeQual (TSCLkernel _) = True isTypeQual _ = False mkTypeQuals :: [TySpec] -> [TypeQual] mkTypeQuals specs = map mk (filter isTypeQual specs) where mk :: TySpec -> TypeQual mk (TSconst loc) = Tconst loc mk (TSvolatile loc) = Tvolatile loc mk (TSAntiTypeQual v loc) = AntiTypeQual v loc mk (TSAntiTypeQuals v loc) = AntiTypeQuals v loc mk (TSinline loc) = Tinline loc mk (TSrestrict loc) = Trestrict loc mk (TSAttr attr) = TAttr attr mk (TS__restrict loc) = T__restrict loc mk (TSCUDAdevice loc) = TCUDAdevice loc mk (TSCUDAglobal loc) = TCUDAglobal loc mk (TSCUDAhost loc) = TCUDAhost loc mk (TSCUDAconstant loc) = TCUDAconstant loc mk (TSCUDAshared loc) = TCUDAshared loc mk (TSCUDArestrict loc) = TCUDArestrict loc mk (TSCUDAnoinline loc) = TCUDAnoinline loc mk (TSCLprivate loc) = TCLprivate loc mk (TSCLlocal loc) = TCLlocal loc mk (TSCLglobal loc) = TCLglobal loc mk (TSCLconstant loc) = TCLconstant loc mk (TSCLreadonly loc) = TCLreadonly loc mk (TSCLwriteonly loc) = TCLwriteonly loc mk (TSCLkernel loc) = TCLkernel loc mk _ = error "internal error in mkTypeQual" isSign :: TySpec -> Bool isSign (TSsigned _) = True isSign (TSunsigned _) = True isSign _ = False hasSign :: [TySpec] -> Bool hasSign specs = any isSign specs mkSign :: [TySpec] -> P (Maybe Sign) mkSign specs = case filter isSign specs of [] -> return Nothing [TSunsigned loc] -> return (Just (Tunsigned loc)) [TSsigned loc] -> return (Just (Tsigned loc)) [_] -> fail "internal error in mkSign" _ -> fail "multiple signs specified" checkNoSign :: [TySpec] -> String -> P () checkNoSign spec msg | hasSign spec = fail msg | otherwise = return () isAttr :: TySpec -> Bool isAttr (TSAttr _) = True isAttr _ = False checkOnlyAttributes :: [TySpec] -> P [Attr] checkOnlyAttributes specs = case filter (not . isAttr) specs of [] -> return attrs spec : _ -> expected ["attribute"] (Just (show spec)) where attrs :: [Attr] attrs = [attr | TSAttr attr <- specs] mkStringConst :: StringLit -> Const mkStringConst (StringLit raw s l) = StringConst raw s l composeDecls :: Decl -> Decl -> Decl composeDecls (DeclRoot _) root = root composeDecls (C.Ptr quals decl loc) root = C.Ptr quals (composeDecls decl root) loc composeDecls (C.BlockPtr quals decl loc) root = C.BlockPtr quals (composeDecls decl root) loc composeDecls (Array quals size decl loc) root = Array quals size (composeDecls decl root) loc composeDecls (Proto decl args loc) root = Proto (composeDecls decl root) args loc composeDecls (OldProto decl args loc) root = OldProto (composeDecls decl root) args loc mkDeclSpec :: [TySpec] -> P DeclSpec mkDeclSpec specs = go (sort rest) where storage ::[Storage] storage = mkStorage specs quals :: [TypeQual] quals = mkTypeQuals specs -- All TypeQuals except for attributes qualsNoAttrs :: [TypeQual] qualsNoAttrs = mkTypeQuals (filter (not . isAttr) specs) -- Attributes pulled from the TySpecs attrTySpecs :: [Attr] attrTySpecs = [attr | TSAttr attr <- specs] rest :: [TySpec] rest = [x | x <- specs , not (isStorage x) && not (isTypeQual x) && not (isSign x)] go :: [TySpec] -> P DeclSpec go [TSvoid l] = do checkNoSign specs "sign specified for void type" return $ cdeclSpec storage quals (Tvoid l) go [TSchar l] = do sign <- mkSign specs return $ cdeclSpec storage quals (Tchar sign l) go [TSshort l] = do sign <- mkSign specs return $ cdeclSpec storage quals (Tshort sign l) go [TSshort _, TSint _] = do sign <- mkSign specs return $ cdeclSpec storage quals (Tshort sign (srclocOf rest)) go [TSint l] = do sign <- mkSign specs return $ cdeclSpec storage quals (Tint sign l) go [TSlong l] = do sign <- mkSign specs return $ cdeclSpec storage quals (Tlong sign l) go [TSlong _, TSint _] = do sign <- mkSign specs return $ cdeclSpec storage quals (Tlong sign (srclocOf rest)) go [TSlong _, TSlong _] = do sign <- mkSign specs return $ cdeclSpec storage quals (Tlong_long sign (srclocOf rest)) go [TSlong _, TSlong _, TSint _] = do sign <- mkSign specs return $ cdeclSpec storage quals (Tlong_long sign (srclocOf rest)) go [TSfloat loc] = do checkNoSign specs "sign specified for float type" return $ cdeclSpec storage quals (Tfloat loc) go [TSdouble loc] = do checkNoSign specs "sign specified for double type" return $ cdeclSpec storage quals (Tdouble loc) go [TSlong _, TSdouble _] = do checkNoSign specs "sign specified for long double type" return $ cdeclSpec storage quals (Tlong_double (srclocOf rest)) go [TSfloat _, TS_Complex _] = do checkNoSign specs "sign specified for float _Complex type" return $ cdeclSpec storage quals (Tfloat_Complex (srclocOf rest)) go [TSdouble _, TS_Complex _] = do checkNoSign specs "sign specified for double _Complex type" return $ cdeclSpec storage quals (Tdouble_Complex (srclocOf rest)) go [TSlong _, TSdouble _, TS_Complex _] = do checkNoSign specs "sign specified for long double _Complex type" return $ cdeclSpec storage quals (Tlong_double_Complex (srclocOf rest)) go [TSfloat _, TS_Imaginary _] = do checkNoSign specs "sign specified for float _Imaginary type" return $ cdeclSpec storage quals (Tfloat_Imaginary (srclocOf rest)) go [TSdouble _, TS_Imaginary _] = do checkNoSign specs "sign specified for double _Imaginary type" return $ cdeclSpec storage quals (Tdouble_Imaginary (srclocOf rest)) go [TSlong _, TSdouble _, TS_Imaginary _] = do checkNoSign specs "sign specified for long double _Imaginary type" return $ cdeclSpec storage quals (Tlong_double_Imaginary (srclocOf rest)) -- Attributes for structs, unions, and enums may appear after the closing -- brace. If this happens, they end up in the list of TypeQuals. We pull -- them out here and associate them with the struct/union/enum. go [TSstruct ident fields attrs loc] = do checkNoSign specs "sign specified for struct type" return $ cdeclSpec storage qualsNoAttrs (Tstruct ident fields (attrTySpecs ++ attrs) loc) go [TSunion ident fields attrs loc] = do checkNoSign specs "sign specified for union type" return $ cdeclSpec storage qualsNoAttrs (Tunion ident fields (attrTySpecs ++ attrs) loc) go [TSenum ident enums attrs loc] = do checkNoSign specs "sign specified for enum type" return $ cdeclSpec storage qualsNoAttrs (Tenum ident enums (attrTySpecs ++ attrs) loc) go [TSnamed ident refs loc] = do checkNoSign specs "sign specified for named type" return $ cdeclSpec storage quals (Tnamed ident refs loc) go [TStypeofExp e loc] = do checkNoSign specs "sign specified for typeof" return $ cdeclSpec storage quals (TtypeofExp e loc) go [TStypeofType ty loc] = do checkNoSign specs "sign specified for typeof" return $ cdeclSpec storage quals (TtypeofType ty loc) go [TS_Bool l] = do checkNoSign specs "sign specified for _Bool" return $ cdeclSpec storage quals (T_Bool l) go [TSva_list l] = do checkNoSign specs "sign specified for __builtin_va_list" return $ cdeclSpec storage quals (Tva_list l) go [] = do sign <- mkSign specs return $ cdeclSpec storage quals (Tint sign (storage `srcspan` quals)) go tyspecs = throw $ ParserException (locOf tyspecs) (text "bad type:" <+> spread (map ppr tyspecs)) mkPtr :: [TySpec] -> Decl -> Decl mkPtr specs decl = C.Ptr quals decl (specs `srcspan` decl) where quals = mkTypeQuals specs mkBlockPtr :: Loc -> [TySpec] -> P (Decl -> Decl) mkBlockPtr loc specs = do assertBlocksEnabled loc "To use blocks, enable the blocks language extension" return $ \decl -> C.BlockPtr quals decl (specs `srcspan` decl) where quals = mkTypeQuals specs mkArray :: [TySpec] -> ArraySize -> Decl -> Decl mkArray specs size decl = Array quals size decl (specs `srcspan` decl) where quals = mkTypeQuals specs mkProto :: Params -> Decl -> Decl mkProto args decl = Proto decl args (args `srcspan` decl) mkOldProto :: [Id] -> Decl -> Decl mkOldProto args decl = OldProto decl args (args `srcspan` decl) checkInitGroup :: DeclSpec -> Decl -> [Attr] -> [Init] -> P InitGroup checkInitGroup dspec decl attrs inits = go dspec where go :: DeclSpec -> P InitGroup go (DeclSpec storage quals tspec _) | any isTypedef storage = do typedefs <- mapM checkInit inits' let dspec' = cdeclSpec storage' quals tspec return $ ctypedefGroup dspec' attrs typedefs where storage' :: [Storage] storage' = [x | x <- storage, (not . isTypedef) x] isTypedef :: Storage -> Bool isTypedef (Ttypedef _) = True isTypedef _ = False checkInit :: Init -> P Typedef checkInit init@(Init ident _ _ (Just _) _ _)= throw $ ParserException (locOf init) $ text "typedef" <+> quoteTok (ppr ident) <+> text "is illegaly initialized" checkInit (Init ident@(Id name _) decl _ _ attrs _) = do addTypedef name return $ ctypedef ident decl attrs checkInit (Init ident@(AntiId _ _) decl _ _ attrs _) = return $ ctypedef ident decl attrs go _ = do mapM_ checkInit inits' return $ cinitGroup dspec attrs inits' where checkInit :: Init -> P () checkInit (Init (Id name _) _ _ _ _ _) = addVariable name checkInit (Init (AntiId _ _) _ _ _ _ _) = return () composeInitDecl :: Decl -> Init -> Init composeInitDecl decl (Init ident initDecl maybe_asmlabel maybe_exp attrs loc) = Init ident (composeDecls initDecl decl) maybe_asmlabel maybe_exp attrs loc inits' = map (composeInitDecl decl) inits loc :: Loc loc = dspec <--> attrs <--> inits checkAnonymousStructOrUnion :: L T.Token -> DeclSpec -> P () checkAnonymousStructOrUnion _ (DeclSpec _ _ (Tstruct {}) _) = return () checkAnonymousStructOrUnion _ (DeclSpec _ _ (Tunion {}) _) = return () checkAnonymousStructOrUnion tok (DeclSpec _ _ (Tunion {}) _) = expectedAt tok ["anonymous struct or union"] Nothing declRoot :: Located a => a -> Decl declRoot x = DeclRoot (srclocOf x) addClassdefId :: Id -> P () addClassdefId (Id str _) = addClassdef str addClassdefId (AntiId {}) = return () assertBlocksEnabled :: Loc -> String -> P () assertBlocksEnabled loc errMsg = do blocks_enabled <- useBlocksExts unless blocks_enabled $ throw $ ParserException loc $ text errMsg expectedObjCPropertyAttr :: Loc -> P a expectedObjCPropertyAttr loc = throw $ ParserException loc $ text "Expected an Objective-C property attribute; allowed are the following:" nest 2 (text "'getter = ', 'setter = :', 'readonly', 'readwrite', 'assign'," <+> text "'retain', 'copy', 'nonatomic', 'atomic', 'strong', 'weak', and 'unsafe_unretained'") assertObjCEnabled :: Loc -> String -> P () assertObjCEnabled loc errMsg = do objc_enabled <- useObjCExts unless objc_enabled $ throw $ ParserException loc $ text errMsg assertCudaEnabled :: Loc -> String -> P () assertCudaEnabled loc errMsg = do cuda_enabled <- useCUDAExts unless cuda_enabled $ throw $ ParserException loc $ text errMsg gccOnly :: Located a => String -> a -> P a gccOnly errMsg x = do gcc_enabled <- useGccExts unless gcc_enabled $ throw $ ParserException (locOf x) $ text errMsg pure x mkBlock :: [BlockItem] -> SrcLoc -> Stm mkBlock items@[BlockStm AntiStms{}] sloc = Block items sloc mkBlock [BlockStm stm] _ = stm mkBlock items sloc = Block items sloc mkBlockItems :: Stm -> [BlockItem] mkBlockItems (Block items _) = items mkBlockItems stm = [BlockStm stm] mkCommentStm :: L T.Token -> Stm -> Stm mkCommentStm tok stm = Comment (getCOMMENT tok) stm (srclocOf tok) mkEmptyCommentStm :: L T.Token -> Stm mkEmptyCommentStm tok = mkCommentStm tok (Exp Nothing noLoc) data RevList a = RNil | RCons a (RevList a) | RApp [a] (RevList a) rnil :: RevList a rnil = RNil rsingleton :: a -> RevList a rsingleton x = RCons x RNil infixr 5 `rcons` rcons :: a -> RevList a -> RevList a rcons x xs = RCons x xs rapp :: [a] -> RevList a -> RevList a rapp xs ys = RApp xs ys rlist :: [a] -> RevList a rlist xs = rlist' xs rnil where rlist' [] acc = acc rlist' (x:xs) acc = rlist' xs (rcons x acc) rev :: RevList a -> [a] rev xs = go [] xs where go l RNil = l go l (RCons x xs) = go (x : l) xs go l (RApp xs ys) = go (xs ++ l) ys instance Located a => Located (RevList a) where locOf RNil = mempty locOf (RCons x xs) = locOf x `mappend` locOf xs locOf (RApp xs ys) = locOf xs `mappend` locOf ys } language-c-quote-0.13.0.2/Language/C/Parser/Tokens.hs0000644000000000000000000006071207346545000020230 0ustar0000000000000000-- | -- Module : Language.C.Parser.Tokens -- Copyright : (c) 2006-2011 Harvard University -- (c) 2011-2013 Geoffrey Mainland -- (c) 2013 Manuel M T Chakravarty -- (c) 2013-2016 Drexel University -- License : BSD-style -- Maintainer : mainland@drexel.edu module Language.C.Parser.Tokens ( Token(..), ExtensionsInt, keywords, keywordMap ) where import Data.Bits import Data.Char (isAlphaNum, isLower) import Data.List (foldl') import qualified Data.Map as Map import Data.Maybe (fromMaybe) import Data.Word import Text.PrettyPrint.Mainland import Text.PrettyPrint.Mainland.Class import Language.C.Syntax (Extensions(..), Signed(..)) data Token = Teof | Tpragma String | Tcomment String -- ^ Raw comment string | TintConst (String, Signed, Integer) | TlongIntConst (String, Signed, Integer) | TlongLongIntConst (String, Signed, Integer) | TfloatConst (String, Float) | TdoubleConst (String, Double) | TlongDoubleConst (String, Double) | TcharConst (String, Char) | TstringConst (String, String) | Tidentifier String | Tnamed String | Tlparen | Trparen | Tlbrack | Trbrack | Tlbrace | Trbrace | Tcomma | Tsemi | Tcolon | Tquestion | Tdot | Tarrow | Tellipses | Tplus | Tminus | Tstar | Tdiv | Tmod | Tnot | Tand | Tor | Txor | Tlsh | Trsh | Tinc | Tdec | Tlnot | Tland | Tlor | Teq | Tne | Tlt | Tgt | Tle | Tge | Tassign | Tadd_assign | Tsub_assign | Tmul_assign | Tdiv_assign | Tmod_assign | Tlsh_assign | Trsh_assign | Tand_assign | Tor_assign | Txor_assign | Tauto | Tbreak | Tcase | Tchar | Tconst | Tcontinue | Tdefault | Tdo | Tdouble | Telse | Tenum | Textern | Tfloat | Tfor | Tgoto | Tif | Tint | Tlong | Tregister | Treturn | Tshort | Tsigned | Tsizeof | Tstatic | Tstruct | Tswitch | Ttypedef | Tunion | Tunsigned | Tvoid | Tvolatile | Twhile | Ttypename | Tanti_id String | Tanti_const String | Tanti_int String | Tanti_uint String | Tanti_lint String | Tanti_ulint String | Tanti_llint String | Tanti_ullint String | Tanti_float String | Tanti_double String | Tanti_long_double String | Tanti_char String | Tanti_string String | Tanti_exp String | Tanti_func String | Tanti_args String | Tanti_decl String | Tanti_decls String | Tanti_sdecl String | Tanti_sdecls String | Tanti_enum String | Tanti_enums String | Tanti_esc String | Tanti_escstm String | Tanti_edecl String | Tanti_edecls String | Tanti_item String | Tanti_items String | Tanti_stm String | Tanti_stms String | Tanti_type_qual String | Tanti_type_quals String | Tanti_type String | Tanti_spec String | Tanti_param String | Tanti_params String | Tanti_pragma String | Tanti_comment String | Tanti_init String | Tanti_inits String | Tanti_attr String | Tanti_attrs String -- C99 | TBool | TComplex | TImaginary | Tinline | Trestrict -- GCC | Tasm | Tattribute | Tbuiltin_va_arg | Tbuiltin_va_list | Textension | Ttypeof | T__restrict -- CUDA | TCUDAmutable | TCUDA3lt | TCUDA3gt | TCUDAdevice | TCUDAglobal | TCUDAhost | TCUDAconstant | TCUDAshared | TCUDArestrict | TCUDAnoinline -- OpenCL | TCLprivate | TCLlocal | TCLglobal | TCLconstant | TCLreadonly | TCLwriteonly | TCLkernel -- Clang (currently active is Objective-C is active) | T__block -- Objective-C | TObjCnamed String | TObjCat | TObjCautoreleasepool | TObjCcatch | TObjCclass | TObjCcompatibility_alias | TObjCdynamic | TObjCencode | TObjCend | TObjCfinally | TObjCimplementation | TObjCinterface | TObjCNO | TObjCprivate | TObjCoptional | TObjCpublic | TObjCproperty | TObjCprotected | TObjCprotocol | TObjCpackage | TObjCrequired | TObjCselector | TObjCsynchronized | TObjCsynthesize | TObjCthrow | TObjCtry | TObjCYES | TObjC__weak | TObjC__strong | TObjC__unsafe_unretained | Tanti_objc_ifdecl String | Tanti_objc_ifdecls String | Tanti_objc_prop String | Tanti_objc_props String | Tanti_objc_prop_attr String | Tanti_objc_prop_attrs String | Tanti_objc_dicts String | Tanti_objc_param String | Tanti_objc_params String | Tanti_objc_method_proto String | Tanti_objc_method_def String | Tanti_objc_method_defs String | Tanti_objc_recv String | Tanti_objc_arg String | Tanti_objc_args String deriving (Ord, Eq) instance Pretty Token where ppr = text . show instance Show Token where show Teof = "EOF" show (Tpragma s) = "#pragma " ++ s show (Tcomment s) = s show (TintConst (s, _, _)) = s show (TlongIntConst (s, _, _)) = s show (TlongLongIntConst (s, _, _)) = s show (TfloatConst (s, _)) = s show (TdoubleConst (s, _)) = s show (TlongDoubleConst (s, _)) = s show (TcharConst (s, _)) = s show (TstringConst (s, _)) = s show (Tidentifier s) = s show (Tnamed s) = s show (Tanti_id s) = showAnti "id" s show (Tanti_const s) = showAnti "const" s show (Tanti_int s) = showAnti "int" s show (Tanti_uint s) = showAnti "uint" s show (Tanti_lint s) = showAnti "lint" s show (Tanti_ulint s) = showAnti "ulint" s show (Tanti_llint s) = showAnti "llint" s show (Tanti_ullint s) = showAnti "ullint" s show (Tanti_float s) = showAnti "float" s show (Tanti_double s) = showAnti "double" s show (Tanti_long_double s) = showAnti "longdouble" s show (Tanti_char s) = showAnti "char" s show (Tanti_string s) = showAnti "string" s show (Tanti_exp s) = showAnti "exp" s show (Tanti_func s) = showAnti "func" s show (Tanti_args s) = showAnti "args" s show (Tanti_decl s) = showAnti "decl" s show (Tanti_decls s) = showAnti "decls" s show (Tanti_sdecl s) = showAnti "sdecl" s show (Tanti_sdecls s) = showAnti "sdecls" s show (Tanti_enum s) = showAnti "enum" s show (Tanti_enums s) = showAnti "enums" s show (Tanti_esc s) = showAnti "esc" s show (Tanti_escstm s) = showAnti "escstm" s show (Tanti_edecl s) = showAnti "edecl" s show (Tanti_edecls s) = showAnti "edecls" s show (Tanti_item s) = showAnti "item" s show (Tanti_items s) = showAnti "items" s show (Tanti_stm s) = showAnti "stm" s show (Tanti_stms s) = showAnti "stms" s show (Tanti_type_quals s) = showAnti "tyquals" s show (Tanti_type_qual s) = showAnti "tyqual" s show (Tanti_type s) = showAnti "ty" s show (Tanti_spec s) = showAnti "spec" s show (Tanti_param s) = showAnti "param" s show (Tanti_params s) = showAnti "params" s show (Tanti_pragma s) = showAnti "pragma" s show (Tanti_comment s) = showAnti "comment" s show (Tanti_init s) = showAnti "init" s show (Tanti_inits s) = showAnti "inits" s show (Tanti_attr s) = showAnti "attr" s show (Tanti_attrs s) = showAnti "attrs" s -- -- Objective C -- show (TObjCnamed s) = s show (Tanti_objc_ifdecl s) = showAnti "ifdecl" s show (Tanti_objc_ifdecls s) = showAnti "ifdecls" s show (Tanti_objc_prop s) = showAnti "prop" s show (Tanti_objc_props s) = showAnti "props" s show (Tanti_objc_prop_attr s) = showAnti "propattr" s show (Tanti_objc_prop_attrs s) = showAnti "propattrs" s show (Tanti_objc_dicts s) = showAnti "dictelems" s show (Tanti_objc_param s) = showAnti "methparam" s show (Tanti_objc_params s) = showAnti "methparams" s show (Tanti_objc_method_proto s) = showAnti "methproto" s show (Tanti_objc_method_def s) = showAnti "methdef" s show (Tanti_objc_method_defs s) = showAnti "methdefs" s show (Tanti_objc_recv s) = showAnti "recv" s show (Tanti_objc_arg s) = showAnti "kwarg" s show (Tanti_objc_args s) = showAnti "kwargs" s show t = fromMaybe (error "language-c-quote: internal error: unknown token") (lookup t tokenStrings) showAnti :: String -> String -> String showAnti anti s = "$" ++ anti ++ ":" ++ if isIdentifier s then s else "(" ++ s ++ ")" where isIdentifier :: String -> Bool isIdentifier [] = False isIdentifier ('_':cs) = all isIdChar cs isIdentifier (c:cs) = isLower c && all isIdChar cs isIdChar :: Char -> Bool isIdChar '_' = True isIdChar c = isAlphaNum c tokenStrings :: [(Token, String)] tokenStrings = [(Tlparen, "("), (Trparen, ")"), (Tlbrack, "["), (Trbrack, "]"), (Tlbrace, "{"), (Trbrace, "}"), (Tcomma, ","), (Tsemi, ";"), (Tcolon, ":"), (Tquestion, "?"), (Tdot, "."), (Tarrow, "->"), (Tellipses, "..."), (Tplus, "+"), (Tminus, "-"), (Tstar, "*"), (Tdiv, "/"), (Tmod, "%"), (Tnot, "~"), (Tand, "&"), (Tor, "|"), (Txor, "^"), (Tlsh, "<<"), (Trsh, ">>"), (Tinc, "++"), (Tdec, "--"), (Tlnot, "!"), (Tland, "&&"), (Tlor, "||"), (Teq, "=="), (Tne, "!="), (Tlt, "<"), (Tgt, ">"), (Tle, "<="), (Tge, ">="), (Tassign, "="), (Tadd_assign, "+="), (Tsub_assign, "-="), (Tmul_assign, "*="), (Tdiv_assign, "/="), (Tmod_assign, "%="), (Tlsh_assign, "<<="), (Trsh_assign, ">>="), (Tand_assign, "&="), (Tor_assign, "|="), (Txor_assign, "^="), -- -- Keywords -- (Tauto, "auto"), (Tbreak, "break"), (Tcase, "case"), (Tchar, "char"), (Tconst, "const"), (Tcontinue, "continue"), (Tdefault, "default"), (Tdo, "do"), (Tdouble, "double"), (Telse, "else"), (Tenum, "enum"), (Textern, "extern"), (Tfloat, "float"), (Tfor, "for"), (Tgoto, "goto"), (Tif, "if"), (Tint, "int"), (Tlong, "long"), (Tregister, "register"), (Treturn, "return"), (Tshort, "short"), (Tsigned, "signed"), (Tsizeof, "sizeof"), (Tstatic, "static"), (Tstruct, "struct"), (Tswitch, "switch"), (Ttypedef, "typedef"), (Tunion, "union"), (Tunsigned, "unsigned"), (Tvoid, "void"), (Tvolatile, "volatile"), (Twhile, "while"), (Ttypename, "typename"), -- -- C99 extensions -- (TBool, "_Bool"), (TComplex, "_TComplex"), (TImaginary, "_TImaginary"), (Tinline, "inline"), (Trestrict, "restrict"), -- -- GCC extensions -- (Tasm, "asm"), (Tattribute, "__attribute__"), (Tbuiltin_va_arg, "__builtin_va_arg"), (Tbuiltin_va_list, "__builtin_va_list"), (Textension, "__extension__"), (Ttypeof, "typeof"), (T__restrict, "__restrict"), -- -- Clang extensions -- (T__block , "__block"), -- -- Objective-C extensions -- (TObjCat , "@"), (TObjCautoreleasepool , "autoreleasepool"), (TObjCcatch , "catch"), (TObjCclass , "class"), (TObjCcompatibility_alias , "compatibility_alias"), (TObjCdynamic , "dynamic"), (TObjCencode , "encode"), (TObjCend , "end"), (TObjCfinally , "finally"), (TObjCimplementation , "implementation"), (TObjCinterface , "interface"), (TObjCNO , "NO"), (TObjCoptional , "optional"), (TObjCprivate , "private"), (TObjCpublic , "public"), (TObjCproperty , "property"), (TObjCprotected , "protected"), (TObjCprotocol , "protocol"), (TObjCpackage , "package"), (TObjCrequired , "required"), (TObjCselector , "selector"), (TObjCsynchronized , "synchronized"), (TObjCsynthesize , "synthesize"), (TObjCthrow , "throw"), (TObjCtry , "try"), (TObjCYES , "YES"), (TObjC__weak , "__weak"), (TObjC__strong , "__strong"), (TObjC__unsafe_unretained , "__unsafe_unretained"), -- -- CUDA extensions -- (TCUDAmutable, "mutable"), (TCUDAdevice, "__device__"), (TCUDAglobal, "__global__"), (TCUDAhost, "__host__"), (TCUDAconstant, "__constant__"), (TCUDAshared, "__shared__"), (TCUDArestrict, "__restrict__"), (TCUDAnoinline, "__noinline__"), -- -- OpenCL extensions -- (TCLprivate, "private"), -- must be without '__' prefix for Objective-C (TCLlocal, "__local"), (TCLglobal, "__global"), (TCLconstant, "__constant"), (TCLreadonly, "read_only"), (TCLwriteonly, "write_only"), (TCLkernel, "__kernel") ] keywords :: [(String, Token, Maybe [Extensions])] keywords = [("auto", Tauto, Nothing), ("break", Tbreak, Nothing), ("case", Tcase, Nothing), ("char", Tchar, Nothing), ("const", Tconst, Nothing), ("continue", Tcontinue, Nothing), ("default", Tdefault, Nothing), ("do", Tdo, Nothing), ("double", Tdouble, Nothing), ("else", Telse, Nothing), ("enum", Tenum, Nothing), ("extern", Textern, Nothing), ("float", Tfloat, Nothing), ("for", Tfor, Nothing), ("goto", Tgoto, Nothing), ("if", Tif, Nothing), ("int", Tint, Nothing), ("long", Tlong, Nothing), ("register", Tregister, Nothing), ("return", Treturn, Nothing), ("short", Tshort, Nothing), ("signed", Tsigned, Nothing), ("sizeof", Tsizeof, Nothing), ("static", Tstatic, Nothing), ("struct", Tstruct, Nothing), ("switch", Tswitch, Nothing), ("typedef", Ttypedef, Nothing), ("union", Tunion, Nothing), ("unsigned", Tunsigned, Nothing), ("void", Tvoid, Nothing), ("volatile", Tvolatile, Nothing), ("while", Twhile, Nothing), -- -- C99 -- ("_Bool", TBool, Nothing), ("_Complex", TComplex, Nothing), ("_Imaginary", TImaginary, Nothing), ("inline", Tinline, Nothing), ("restrict", Trestrict, Nothing), -- -- GCC -- ("asm", Tasm, Just [Gcc]), ("__asm", Tasm, Just [Gcc]), ("__asm__", Tasm, Just [Gcc]), ("__attribute__", Tattribute, Just [Gcc]), ("__builtin_va_arg", Tbuiltin_va_arg, Just [Gcc]), ("__builtin_va_list", Tbuiltin_va_list, Just [Gcc]), ("__const", Tconst, Just [Gcc]), ("__const__", Tconst, Just [Gcc]), ("__inline", Tinline, Just [Gcc]), ("__inline__", Tinline, Just [Gcc]), ("__restrict", T__restrict, Just [Gcc]), ("__restrict__", T__restrict, Just [Gcc]), ("typeof", Ttypeof, Just [Gcc]), ("__typeof", Ttypeof, Just [Gcc]), ("__typeof__", Ttypeof, Just [Gcc]), ("__volatile", Tvolatile, Just [Gcc]), ("__volatile__", Tvolatile, Just [Gcc]), -- -- Clang blocks -- ("__block", T__block, Just [Blocks, ObjC]), -- -- Objective-C -- ("autoreleasepool", TObjCautoreleasepool, Just [ObjC]), ("catch", TObjCcatch, Just [ObjC]), ("class", TObjCclass, Just [ObjC]), ("compatibility_alias", TObjCcompatibility_alias, Just [ObjC]), ("dynamic", TObjCdynamic, Just [ObjC]), ("encode", TObjCencode, Just [ObjC]), ("end", TObjCend, Just [ObjC]), ("finally", TObjCfinally, Just [ObjC]), ("implementation", TObjCimplementation, Just [ObjC]), ("interface", TObjCinterface, Just [ObjC]), ("NO", TObjCNO, Just [ObjC]), ("optional", TObjCoptional, Just [ObjC]), ("public", TObjCpublic, Just [ObjC]), ("property", TObjCproperty, Just [ObjC]), ("protected", TObjCprotected, Just [ObjC]), ("package", TObjCpackage, Just [ObjC]), ("protocol", TObjCprotocol, Just [ObjC]), ("required", TObjCrequired, Just [ObjC]), ("selector", TObjCselector, Just [ObjC]), ("synchronized", TObjCsynchronized, Just [ObjC]), ("synthesize", TObjCsynthesize, Just [ObjC]), ("throw", TObjCthrow, Just [ObjC]), ("try", TObjCtry, Just [ObjC]), ("YES", TObjCYES, Just [ObjC]), ("__weak", TObjC__weak, Just [ObjC]), ("__strong", TObjC__strong, Just [ObjC]), ("__unsafe_unretained", TObjC__unsafe_unretained, Just [ObjC]), -- -- CUDA -- ("mutable", TCUDAmutable, Just [CUDA]), ("__device__", TCUDAdevice, Just [CUDA]), ("__global__", TCUDAglobal, Just [CUDA]), ("__host__", TCUDAhost, Just [CUDA]), ("__constant__", TCUDAconstant, Just [CUDA]), ("__shared__", TCUDAshared, Just [CUDA]), ("__restrict__", TCUDArestrict, Just [CUDA]), ("__noinline__", TCUDAnoinline, Just [CUDA]), -- -- OpenCL -- ("private", TCLprivate, Just [OpenCL, ObjC]), -- see Lexer.identifier for 'TObjCprivate' ("__private", TCLprivate, Just [OpenCL]), ("local", TCLlocal, Just [OpenCL]), ("__local", TCLlocal, Just [OpenCL]), ("global", TCLglobal, Just [OpenCL]), ("__global", TCLglobal, Just [OpenCL]), ("constant", TCLconstant, Just [OpenCL]), ("__constant", TCLconstant, Just [OpenCL]), ("read_only", TCLreadonly, Just [OpenCL]), ("__read_only", TCLreadonly, Just [OpenCL]), ("write_only", TCLwriteonly, Just [OpenCL]), ("__write_only", TCLwriteonly, Just [OpenCL]), ("kernel", TCLkernel, Just [OpenCL]), ("__kernel", TCLkernel, Just [OpenCL]) ] type ExtensionsInt = Word32 keywordMap :: Map.Map String (Token, Maybe ExtensionsInt) keywordMap = Map.fromList (map f keywords) where f :: (String, Token, Maybe [Extensions]) -> (String, (Token, Maybe ExtensionsInt)) f (s, t, Nothing) = (s, (t, Nothing)) f (s, t, Just exts) = (s, (t, Just i)) where i = foldl' setBit 0 (map fromEnum exts) language-c-quote-0.13.0.2/Language/C/Pretty.hs0000644000000000000000000011244107346545000017015 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleInstances #-} {-# OPTIONS_GHC -fno-warn-orphans #-} -- | -- Module : Language.C.Pretty -- Copyright : (c) 2006-2011 Harvard University -- (c) 2011-2013 Geoffrey Mainland -- : (c) 2013-2016 Drexel University -- License : BSD-style -- Maintainer : mainland@drexel.edu module Language.C.Pretty where import Data.Char (isAlphaNum, isLower) import Data.Loc import Data.Maybe (isJust) #if !(MIN_VERSION_base(4,9,0)) import Data.Monoid (Monoid(..), (<>)) #endif /* !(MIN_VERSION_base(4,9,0)) */ #if MIN_VERSION_base(4,9,0) && !(MIN_VERSION_base(4,11,0)) import Data.Semigroup (Semigroup(..)) #endif import Language.C.Syntax import Text.PrettyPrint.Mainland import Text.PrettyPrint.Mainland.Class pprLoc :: SrcLoc -> Doc -> Doc pprLoc loc doc = srcloc loc <> doc data Fixity = Fixity Assoc Int deriving (Eq, Ord) data Assoc = LeftAssoc | RightAssoc | NonAssoc deriving (Eq, Ord) infix_ :: Int -> Fixity infix_ = Fixity NonAssoc infixl_ :: Int -> Fixity infixl_ = Fixity LeftAssoc infixr_ :: Int -> Fixity infixr_ = Fixity RightAssoc -- | Pretty print infix binary operators infixop :: (Pretty a, Pretty b, Pretty op, CFixity op) => Int -- ^ precedence of context -> op -- ^ operator -> a -- ^ left argument -> b -- ^ right argument -> Doc infixop prec op l r = parensOp prec op $ pprPrec leftPrec l <+> ppr op <+/> pprPrec rightPrec r where leftPrec | opAssoc == RightAssoc = opPrec + 1 | otherwise = opPrec rightPrec | opAssoc == LeftAssoc = opPrec + 1 | otherwise = opPrec Fixity opAssoc opPrec = fixity op -- | Pretty print prefix unary operators prefixop :: (Pretty a, Pretty op, CFixity op) => Int -- ^ precedence of context -> op -- ^ operator -> a -- ^ argument -> Doc prefixop prec op arg = parensIf (prec > opPrec) $ ppr op <> pprPrec rightPrec arg where rightPrec | opAssoc == LeftAssoc = opPrec + 1 | otherwise = opPrec Fixity opAssoc opPrec = fixity op parensList :: [Doc] -> Doc parensList = enclosesep lparen rparen comma bracesList :: [Doc] -> Doc bracesList = enclosesep lbrace rbrace comma bracesSemiList :: [Doc] -> Doc bracesSemiList = enclosesep lbrace rbrace semi angleList :: [Doc] -> Doc angleList = enclosesep langle rangle comma embrace :: [Doc] -> Doc embrace [] = lbrace <+> rbrace embrace ds = lbrace <> nest 4 (line <> stack ds) rbrace pprAnti :: String -> String -> Doc pprAnti anti s = char '$' <> text anti <> colon <> if isIdentifier s then text s else parens (text s) where isIdentifier :: String -> Bool isIdentifier [] = False isIdentifier ('_':cs) = all isIdChar cs isIdentifier (c:cs) = isLower c && all isIdChar cs isIdChar :: Char -> Bool isIdChar '_' = True isIdChar c = isAlphaNum c class CFixity a where fixity :: a -> Fixity parensOp :: Int -> a -> Doc -> Doc parensOp prec op = parensIf (prec > opPrec) where Fixity _ opPrec = fixity op -- -- Fixities are taken from Table 2-1 in Section 2.12 of K&R (2nd ed.) -- commaPrec :: Int commaPrec = 1 commaPrec1 :: Int commaPrec1 = commaPrec + 1 condPrec :: Int condPrec = 3 condPrec1 :: Int condPrec1 = condPrec + 1 unopPrec :: Int unopPrec = 14 unopPrec1 :: Int unopPrec1 = unopPrec + 1 memberPrec :: Int memberPrec = 15 memberPrec1 :: Int memberPrec1 = memberPrec + 1 instance CFixity BinOp where fixity Add = infixl_ 12 fixity Sub = infixl_ 12 fixity Mul = infixl_ 13 fixity Div = infixl_ 13 fixity Mod = infixl_ 13 fixity Eq = infixl_ 9 fixity Ne = infixl_ 9 fixity Lt = infixl_ 10 fixity Gt = infixl_ 10 fixity Le = infixl_ 10 fixity Ge = infixl_ 10 fixity Land = infixl_ 5 fixity Lor = infixl_ 4 fixity And = infixl_ 8 fixity Or = infixl_ 6 fixity Xor = infixl_ 7 fixity Lsh = infixl_ 11 fixity Rsh = infixl_ 11 parensOp prec op = go op where go :: BinOp -> Doc -> Doc go Add | isBitwiseOp = parens go Sub | isBitwiseOp = parens go Land | isOp Lor = parens go Lor | isOp Land = parens go And | isOp Or = parens | isOp Xor = parens go Or | isOp And = parens | isOp Xor = parens go Xor | isOp And = parens | isOp Or = parens go _ = parensIf (prec > opPrec) isBitwiseOp :: Bool isBitwiseOp = isOp And || isOp Or || isOp Xor -- Return 'True' if we are potentially an immediate subterm of the -- binary operator op'. We make this determination based of the value of -- @prec@. isOp :: BinOp -> Bool isOp op' = prec == op'Prec || prec == op'Prec + 1 where Fixity _ op'Prec = fixity op' Fixity _ opPrec = fixity op instance CFixity AssignOp where fixity _ = infixr_ 2 instance CFixity UnOp where fixity _ = infixr_ unopPrec instance Pretty Id where ppr (Id ident _) = text ident ppr (AntiId v _) = pprAnti "id" v instance Pretty StringLit where ppr (StringLit ss _ _) = sep (map string ss) instance Pretty Storage where ppr (Tauto _) = text "auto" ppr (Tregister _) = text "register" ppr (Tstatic _) = text "static" ppr (Textern Nothing _) = text "extern" ppr (Textern (Just l) _) = text "extern" <+> ppr l ppr (Ttypedef _) = text "typedef" ppr (T__block _) = text "__block" ppr (TObjC__weak _) = text "__weak" ppr (TObjC__strong _) = text "__strong" ppr (TObjC__unsafe_unretained _) = text "__unsafe_unretained" instance Pretty TypeQual where ppr (Tconst _) = text "const" ppr (Tvolatile _) = text "volatile" ppr (EscTypeQual esc _) = text esc ppr (AntiTypeQual v _) = pprAnti "tyqual" v ppr (AntiTypeQuals v _) = pprAnti "tyquals" v ppr (Tinline _) = text "inline" ppr (Trestrict _) = text "restrict" ppr (TAttr attr) = ppr [attr] ppr (T__restrict _) = text "__restrict" ppr (TCUDAdevice _) = text "__device__" ppr (TCUDAglobal _) = text "__global__" ppr (TCUDAhost _) = text "__host__" ppr (TCUDAconstant _) = text "__constant__" ppr (TCUDAshared _) = text "__shared__" ppr (TCUDArestrict _) = text "__restrict__" ppr (TCUDAnoinline _) = text "__noinline__" ppr (TCLprivate _) = text "__private" ppr (TCLlocal _) = text "__local" ppr (TCLglobal _) = text "__global" ppr (TCLconstant _) = text "__constant" ppr (TCLreadonly _) = text "read_only" ppr (TCLwriteonly _) = text "write_only" ppr (TCLkernel _) = text "__kernel" instance Pretty Sign where ppr (Tsigned _) = text "signed" ppr (Tunsigned _) = text "unsigned" instance Pretty TypeSpec where ppr (Tvoid _) = text "void" ppr (Tchar sign _) = ppr sign <+> text "char" ppr (Tshort sign _) = ppr sign <+> text "short" ppr (Tint sign _) = ppr sign <+> text "int" ppr (Tlong sign _) = ppr sign <+> text "long" ppr (Tlong_long sign _) = ppr sign <+> text "long long" ppr (Tfloat _) = text "float" ppr (Tdouble _) = text "double" ppr (Tlong_double _) = text "long double" ppr (Tstruct maybe_ident maybe_fields attrs _) = align $ pprStructOrUnion "struct" maybe_ident maybe_fields attrs ppr (Tunion maybe_ident maybe_fields attrs _) = align $ pprStructOrUnion "union" maybe_ident maybe_fields attrs ppr (Tenum maybe_ident cenums attrs _) = align $ pprEnum maybe_ident cenums attrs ppr (Tnamed ident refs _) = ppr ident <> if null refs then empty else angles (commasep (map ppr refs)) ppr (T_Bool _) = text "_Bool" ppr (Tfloat_Complex _) = text "float" <+> text "_Complex" ppr (Tdouble_Complex _) = text "double" <+> text "_Complex" ppr (Tlong_double_Complex _) = text "long" <+> text "double" <+> text "_Complex" ppr (Tfloat_Imaginary _) = text "float" <+> text "_Imaginary" ppr (Tdouble_Imaginary _) = text "double" <+> text "_Imaginary" ppr (Tlong_double_Imaginary _) = text "long" <+> text "double" <+> text "_Imaginary" ppr (TtypeofExp e _) = text "__typeof__" <> parens (pprPrec 14 e) ppr (TtypeofType tipe _) = text "__typeof__" <> parens (ppr tipe) ppr (Tva_list _) = text "__builtin_va_list" pprStructOrUnion :: String -> Maybe Id -> Maybe [FieldGroup] -> [Attr] -> Doc pprStructOrUnion ty maybe_ident maybe_fields attrs = text ty <+> ppr maybe_ident <+> ppr maybe_fields <+/> ppr attrs pprEnum :: Maybe Id -> [CEnum] -> [Attr] -> Doc pprEnum maybe_ident cenums attrs = text "enum" <+> ppr maybe_ident <+> ppr cenums <+/> ppr attrs instance Pretty DeclSpec where ppr (DeclSpec storage quals spec _) = case map ppr storage ++ map ppr quals of [] -> ppr spec docs -> spread docs <+/> ppr spec ppr (AntiDeclSpec v _) = pprAnti "spec" v ppr (AntiTypeDeclSpec storage quals v _) = spread (map ppr storage ++ map ppr quals) <+/> pprAnti "ty" v instance Pretty ArraySize where ppr (ArraySize True e _) = text "static" <+> ppr e ppr (ArraySize False e _) = ppr e ppr (VariableArraySize _) = text "*" ppr (NoArraySize _) = empty pprDeclarator :: Maybe Id -> Decl -> Doc pprDeclarator maybe_ident declarator = case maybe_ident of Nothing -> pprDecl declarator empty Just ident -> pprDecl declarator (ppr ident) where pprPtr :: Decl -> Doc -> (Decl, Doc) pprPtr (Ptr quals decl _) post = pprPtr decl $ text "*" <> spread (map ppr quals) <+> post pprPtr (BlockPtr quals decl _) post = pprPtr decl $ text "^" <> spread (map ppr quals) <+> post pprPtr decl post = (decl, post) pprDirDecl :: Decl -> Doc -> (Decl, Doc) pprDirDecl (Array quals size decl _) pre = pprDirDecl decl $ pre <> brackets (align (spread (map ppr quals) <+> ppr size)) pprDirDecl (Proto decl args _) pre = pprDirDecl decl $ pre <> parens (ppr args) pprDirDecl (OldProto decl args _) pre = pprDirDecl decl $ pre <> parensList (map ppr args) pprDirDecl decl pre = (decl, pre) pprDecl :: Decl -> Doc -> Doc pprDecl decl mid = case decl' of DeclRoot {} -> declDoc AntiTypeDecl {} -> declDoc _ -> pprDecl decl' (parens declDoc) where (decl', declDoc) = uncurry pprPtr (pprDirDecl decl mid) instance Pretty Type where ppr (Type spec decl _) = ppr spec <+> pprDeclarator Nothing decl ppr (AntiType v _) = pprAnti "ty" v instance Pretty Designator where ppr (IndexDesignator e _) = brackets $ ppr e ppr (MemberDesignator ident _) = dot <> ppr ident instance Pretty Designation where ppr (Designation ds _) = folddoc (<>) (map ppr ds) instance Pretty Initializer where ppr (ExpInitializer e _) = ppr e ppr (CompoundInitializer inits _) = bracesList (map pprInit inits) where pprInit :: (Maybe Designation, Initializer) -> Doc pprInit (Nothing, ini) = ppr ini pprInit (Just d, ini) = ppr d <+> text "=" ppr ini ppr (AntiInit v _) = pprAnti "init" v ppr (AntiInits v _) = pprAnti "inits" v instance Pretty Init where ppr (Init ident decl maybe_asmlabel maybe_e attrs _) = pprDeclarator (Just ident) decl <+/> ppr attrs <+> case maybe_asmlabel of Nothing -> empty Just l -> text "asm" <+> parens (ppr l) <+> case maybe_e of Nothing -> empty Just e -> text "=" <+/> ppr e instance Pretty Typedef where ppr (Typedef ident decl attrs loc) = ppr (Init ident decl Nothing Nothing attrs loc) instance Pretty InitGroup where ppr (InitGroup spec attrs inits _) = ppr spec <+/> ppr attrs <+> commasep (map ppr inits) ppr (TypedefGroup spec attrs typedefs _) = text "typedef" <+> ppr spec <+/> ppr attrs <+> commasep (map ppr typedefs) ppr (AntiDecls v _) = pprAnti "decls" v ppr (AntiDecl v _) = pprAnti "decl" v pprList initgroups = stack (zipWith (<>) (map ppr initgroups) (repeat semi)) instance Pretty Field where ppr (Field maybe_ident maybe_decl maybe_e _) = case maybe_decl of Nothing -> empty Just decl -> pprDeclarator maybe_ident decl <+> case maybe_e of Nothing -> empty Just e -> colon <+> ppr e instance Pretty FieldGroup where ppr (FieldGroup spec fields _) = ppr spec <+> commasep (map ppr fields) ppr (AntiSdecls v _) = pprAnti "sdecls" v ppr (AntiSdecl v _) = pprAnti "sdecl" v pprList fields = embrace (zipWith (<>) (map ppr fields) (repeat semi)) instance Pretty CEnum where ppr (CEnum ident maybe_e _) = ppr ident <+> case maybe_e of Nothing -> empty Just e -> text "=" <+/> ppr e ppr (AntiEnums v _) = pprAnti "enums" v ppr (AntiEnum v _) = pprAnti "enum" v pprList [] = empty pprList cenums = embrace (zipWith (<>) (map ppr cenums) (repeat comma)) instance Pretty Attr where ppr (Attr ident [] _) = ppr ident ppr (Attr ident args _) = ppr ident <> parens (commasep (map ppr args)) ppr (AntiAttr v _) = pprAnti "attr" v ppr (AntiAttrs v _) = pprAnti "attrs" v pprList [] = empty pprList attrs = text "__attribute__" <> parens (parens (commasep (map ppr attrs))) instance Pretty Param where ppr (Param maybe_ident spec decl _) = ppr spec <+> pprDeclarator maybe_ident decl ppr (AntiParams v _) = pprAnti "params" v ppr (AntiParam v _) = pprAnti "param" v instance Pretty Params where ppr (Params args True _) = commasep (map ppr args ++ [text "..."]) ppr (Params args False _) = commasep (map ppr args) instance Pretty Func where ppr (Func spec ident decl args body loc) = ppr spec <+> pprDeclarator (Just ident) (Proto decl args loc) ppr body ppr (OldFunc spec ident decl args maybe_initgroups body loc) = ppr spec <+> pprDeclarator (Just ident) (OldProto decl args loc) ppr maybe_initgroups ppr body instance Pretty Definition where ppr (FuncDef func loc) = srcloc loc <> ppr func ppr (DecDef initgroup loc) = srcloc loc <> ppr initgroup <> semi ppr (EscDef s loc) = srcloc loc <> text s ppr (ObjCClassDec clss loc) = srcloc loc <> text "@class" <+> commasep (map ppr clss) <> semi ppr (AntiFunc v _) = pprAnti "func" v ppr (AntiEsc v _) = pprAnti "esc" v ppr (AntiEdecls v _) = pprAnti "edecls" v ppr (AntiEdecl v _) = pprAnti "edecl" v ppr (ObjCClassIface cident sident refs ivars decls attrs loc) = srcloc loc <+> ppr attrs <+/> text "@interface" <+> ppr cident <+> maybe empty (\ident -> char ':' <+> ppr ident) sident <+> pprIfaceBody refs ivars decls ppr (ObjCCatIface cident catident refs ivars decls loc) = srcloc loc <> text "@interface" <+> ppr cident <+> parens (maybe empty ppr catident) <+> pprIfaceBody refs ivars decls ppr (ObjCProtDec prots loc) = srcloc loc <> text "@protocol" <+> commasep (map ppr prots) <> semi ppr (ObjCProtDef pident refs decls loc) = srcloc loc <> text "@protocol" <+> ppr pident <+> pprIfaceBody refs [] decls ppr (ObjCClassImpl cident sident ivars defs loc) = srcloc loc <> text "@implementation" <+> ppr cident <+> maybe empty (\ident -> char ':' <+> ppr ident) sident stack (map ppr ivars) stack (map ppr defs) text "@end" ppr (ObjCCatImpl cident catident defs loc) = srcloc loc <> text "@implementation" <+> ppr cident <+> parens (ppr catident) stack (map ppr defs) text "@end" ppr (ObjCSynDef pivars loc) = srcloc loc <> text "@synthesize" <+> commasep (map pprPivar pivars) <> semi where pprPivar (ident, Nothing) = ppr ident pprPivar (ident1, Just ident2) = ppr ident1 <> char '=' <> ppr ident2 ppr (ObjCDynDef pivars loc) = srcloc loc <> text "@dynamic" <+> commasep (map ppr pivars) <> semi ppr (ObjCMethDef proto body loc) = srcloc loc <> ppr proto ppr body ppr (ObjCCompAlias aident cident loc) = srcloc loc <> text "@compatibility_alias" <+> ppr aident <+> ppr cident ppr (AntiObjCMeth v _) = pprAnti "methdef" v ppr (AntiObjCMeths v _) = pprAnti "methdefs" v pprList ds = stack (map ppr ds) <> line pprIfaceBody :: [Id] -> [ObjCIvarDecl] -> [ObjCIfaceDecl] -> Doc pprIfaceBody refs ivars decls = case refs of [] -> empty _ -> angleList (map ppr refs) stack (map ppr ivars) stack (map ppr decls) text "@end" instance Pretty Stm where ppr (Label ident attrs stm sloc) = srcloc sloc <> indent (-2) (line <> ppr ident <> colon <+> ppr attrs) ppr stm ppr (Case e stm sloc) = srcloc sloc <> indent (-2) (line <> text "case" <+> ppr e <> colon) ppr stm ppr (CaseRange e1 e2 stm sloc) = srcloc sloc <> indent (-2) (line <> text "case" <+> ppr e1 <+> text "..." <+> ppr e2 <> colon) ppr stm ppr (Default stm sloc) = srcloc sloc <> indent (-2) (line <> text "default" <> colon) ppr stm ppr (Exp Nothing sloc) = srcloc sloc <> semi ppr (Exp (Just e) sloc) = srcloc sloc <> hang 4 (ppr e) <> semi ppr (Block items sloc) = srcloc sloc <> ppr items ppr (If test then' maybe_else sloc) = srcloc sloc <> text "if" <+> parens (ppr test) <> pprThen then' (fmap pprElse maybe_else) where isIf :: Stm -> Bool isIf If{} = True isIf (Comment _ stm _) = isIf stm isIf _ = False pprThen :: Stm -> Maybe Doc -> Doc pprThen stm@(Block {}) rest = space <> ppr stm <+> maybe empty id rest pprThen stm rest | isIf stm = space <> ppr [BlockStm stm] <+> maybe empty id rest pprThen stm Nothing = nest 4 (line <> ppr stm) pprThen stm (Just rest) = nest 4 (line <> ppr stm) rest pprElse :: Stm -> Doc pprElse stm = text "else" <> go stm where go :: Stm -> Doc go (Block {}) = space <> ppr stm go (If {}) = space <> ppr stm go _stm = nest 4 (line <> ppr stm) ppr (Switch e stm sloc) = srcloc sloc <> text "switch" <+> parens (ppr e) <> pprBlock stm ppr (While e stm sloc) = srcloc sloc <> text "while" <+> parens (ppr e) <> pprBlock stm ppr (DoWhile stm e sloc) = srcloc sloc <> text "do" <> pprBlock stm <+/> text "while" <> parens (ppr e) <> semi ppr (For ini test post stm sloc) = srcloc sloc <> text "for" <+> (parens . semisep) [either ppr ppr ini, ppr test, ppr post] <> pprBlock stm ppr (Goto ident sloc) = srcloc sloc <> text "goto" <+> ppr ident <> semi ppr (Continue sloc) = srcloc sloc <> text "continue" <>semi ppr (Break sloc) = srcloc sloc <> text "break" <> semi ppr (Return Nothing sloc) = srcloc sloc <> text "return" <> semi ppr (Return (Just e) sloc) = srcloc sloc <> nest 4 (text "return" <+> ppr e) <> semi ppr (Pragma pragma sloc) = srcloc sloc <> text "#pragma" <+> text pragma ppr (Comment com stm sloc) = align $ srcloc sloc <> text com ppr stm ppr (EscStm esc sloc) = srcloc sloc <> text esc ppr (AntiEscStm v _) = pprAnti "escstm" v ppr (AntiPragma v _) = pprAnti "pragma" v ppr (AntiComment v stm _) = pprAnti "pragma" v ppr stm ppr (AntiStm v _) = pprAnti "stm" v ppr (AntiStms v _) = pprAnti "stms" v ppr (Asm isVolatile _ template outs ins clobbered sloc) = srcloc sloc <> text "__asm__" <> case isVolatile of True -> space <> text "__volatile__" False -> empty <> parens (ppr template <> case outs of [] -> space <> colon _ -> colon <+/> ppr outs <> case ins of [] -> space <> colon _ -> colon <+/> ppr ins <> case clobbered of [] -> space <> colon _ -> colon <+/> commasep (map text clobbered) ) <> semi ppr (AsmGoto isVolatile _ template ins clobbered labels sloc) = srcloc sloc <> text "__asm__" <> case isVolatile of True -> space <> text "__volatile__" False -> empty <> parens (ppr template <> colon <> case ins of [] -> space <> colon _ -> colon <+/> ppr ins <> case clobbered of [] -> space <> colon _ -> colon <+/> commasep (map text clobbered) <> case clobbered of [] -> space <> colon _ -> colon <+/> commasep (map ppr labels) ) <> semi ppr (ObjCTry try catchs finally sloc) = srcloc sloc <> text "@try" ppr try stack (map ppr catchs) case finally of Nothing -> empty Just block -> text "@finally" ppr block ppr (ObjCThrow e sloc) = srcloc sloc <> text "@throw" <> case e of Nothing -> semi Just e' -> space <> ppr e' <> semi ppr (ObjCSynchronized e block sloc) = srcloc sloc <> text "@synchronized" <+> parens (ppr e) ppr block ppr (ObjCAutoreleasepool block sloc) = srcloc sloc <> text "@autoreleasepool" ppr block pprBlock :: Stm -> Doc pprBlock stm@(Block {}) = space <> ppr stm pprBlock stm@(If {}) = space <> ppr [BlockStm stm] pprBlock stm = nest 4 $ line <> ppr stm instance Pretty BlockItem where ppr (BlockDecl decl) = ppr decl <> semi ppr (BlockStm stm) = ppr stm ppr (AntiBlockItem v _) = pprAnti "item" v ppr (AntiBlockItems v _) = pprAnti "items" v pprList = embrace . loop where loop :: [BlockItem] -> [Doc] loop [] = [] loop [item] = [ppr item] loop (item1@(BlockDecl _) : item2@(BlockStm _) : items) = (ppr item1 <> line) : loop (item2 : items) loop (item1@(BlockStm _) : item2@(BlockDecl _) : items) = (ppr item1 <> line) : loop (item2 : items) loop (item : items) = ppr item : loop items instance Pretty Const where pprPrec p (IntConst s _ i _) = parensIf (i < 0 && p > unopPrec) $ text s pprPrec p (LongIntConst s _ i _) = parensIf (i < 0 && p > unopPrec) $ text s pprPrec p (LongLongIntConst s _ i _) = parensIf (i < 0 && p > unopPrec) $ text s pprPrec p (FloatConst s r _) = parensIf (r < 0 && p > unopPrec) $ text s pprPrec p (DoubleConst s r _) = parensIf (r < 0 && p > unopPrec) $ text s pprPrec p (LongDoubleConst s r _) = parensIf (r < 0 && p > unopPrec) $ text s pprPrec _ (CharConst s _ _) = text s pprPrec _ (StringConst ss _ _) = sep (map string ss) pprPrec _ (AntiConst v _) = pprAnti "const" v pprPrec _ (AntiString v _) = pprAnti "string" v pprPrec _ (AntiChar v _) = pprAnti "char" v pprPrec _ (AntiLongDouble v _) = pprAnti "ldouble" v pprPrec _ (AntiDouble v _) = pprAnti "double" v pprPrec _ (AntiFloat v _) = pprAnti "float" v pprPrec _ (AntiULInt v _) = pprAnti "ulint" v pprPrec _ (AntiLInt v _) = pprAnti "lint" v pprPrec _ (AntiULLInt v _) = pprAnti "ullint" v pprPrec _ (AntiLLInt v _) = pprAnti "llint" v pprPrec _ (AntiUInt v _) = pprAnti "uint" v pprPrec _ (AntiInt v _) = pprAnti "int" v instance Pretty Exp where pprPrec p (Var ident loc) = pprLoc loc $ pprPrec p ident pprPrec p (Const k loc) = pprLoc loc $ pprPrec p k pprPrec p (BinOp op e1 e2 loc) = pprLoc loc $ infixop p op e1 e2 pprPrec p (Assign e1 op e2 loc) = pprLoc loc $ infixop p op e1 e2 pprPrec p (PreInc e loc) = pprLoc loc $ parensIf (p > unopPrec) $ text "++" <> pprPrec unopPrec1 e pprPrec p (PostInc e loc) = pprLoc loc $ parensIf (p > unopPrec) $ pprPrec unopPrec1 e <> text "++" pprPrec p (PreDec e loc) = pprLoc loc $ parensIf (p > unopPrec) $ text "--" <> pprPrec unopPrec1 e pprPrec p (PostDec e loc) = pprLoc loc $ parensIf (p > unopPrec) $ pprPrec unopPrec1 e <> text "--" pprPrec _ (EscExp e loc) = srcloc loc <> text e pprPrec p (AntiEscExp e loc) = pprLoc loc $ parensIf (p > unopPrec) $ text e -- When printing leading + and - operators, we print the argument at -- precedence 'unopPrec1' to ensure we get parentheses in cases like -- @-(-42)@. The same holds for @++@ and @--@ above. pprPrec p (UnOp op@Positive e loc) = pprLoc loc $ parensIf (p > unopPrec) $ ppr op <> pprPrec unopPrec1 e pprPrec p (UnOp op@Negate e loc) = pprLoc loc $ parensIf (p > unopPrec) $ ppr op <> pprPrec unopPrec1 e pprPrec p (UnOp op e loc) = pprLoc loc $ prefixop p op e pprPrec p (SizeofExp e loc) = pprLoc loc $ parensIf (p > unopPrec) $ text "sizeof" <> parens (ppr e) pprPrec p (SizeofType tipe loc) = pprLoc loc $ parensIf (p > unopPrec) $ text "sizeof" <> parens (ppr tipe) pprPrec p (Cast tipe e loc) = pprLoc loc $ parensIf (p > unopPrec) $ parens (ppr tipe) <+> pprPrec unopPrec e pprPrec p (Cond test then' else' loc) = pprLoc loc $ parensIf (p > condPrec) $ pprPrec condPrec1 test <+> text "?" <+> pprPrec condPrec1 then' <+> colon <+> pprPrec condPrec else' pprPrec p (Member e ident loc) = pprLoc loc $ parensIf (p > memberPrec) $ pprPrec memberPrec e <> dot <> ppr ident pprPrec p (PtrMember e ident loc) = pprLoc loc $ parensIf (p > memberPrec) $ pprPrec memberPrec e <> text "->" <> ppr ident pprPrec p (Index e1 e2 loc) = pprLoc loc $ parensIf (p > memberPrec) $ pprPrec memberPrec e1 <> brackets (ppr e2) pprPrec p (FnCall f args loc) = pprLoc loc $ parensIf (p > memberPrec) $ pprPrec memberPrec f <> parensList (map ppr args) pprPrec p (Seq e1 e2 loc) = pprLoc loc $ parensIf (p > commaPrec) $ pprPrec commaPrec e1 <> comma <+/> pprPrec commaPrec1 e2 pprPrec p (CompoundLit ty inits loc) = pprLoc loc $ parensIf (p > memberPrec) $ parens (ppr ty) <+> braces (commasep (map pprInit inits)) where pprInit :: (Maybe Designation, Initializer) -> Doc pprInit (Nothing, ini) = ppr ini pprInit (Just d, ini) = ppr d <+> text "=" <+/> ppr ini pprPrec _ (StmExpr blockItems loc) = pprLoc loc $ parens $ ppr blockItems pprPrec _ (BuiltinVaArg e ty loc) = pprLoc loc $ text "__builtin_va_arg(" <> ppr e <> comma <+> ppr ty <> rparen pprPrec _ (BlockLit ty attrs block loc) = pprLoc loc $ char '^' <> ppr ty <> (if null attrs then empty else softline <> ppr attrs) <+> ppr block pprPrec p (CudaCall f config args loc) = pprLoc loc $ parensIf (p > memberPrec) $ pprPrec memberPrec f <> text "<<<" <> pprConfig config <> text ">>>" <> parensList (map ppr args) where pprConfig :: ExeConfig -> Doc pprConfig conf = commasep $ [ppr (exeGridDim conf), ppr (exeBlockDim conf)] ++ (case exeSharedSize conf of Nothing -> [] Just e -> [ppr e]) ++ (case exeStream conf of Nothing -> [] Just e -> [ppr e]) pprPrec _ (ObjCMsg recv args varArgs loc1) = pprLoc loc1 $ brackets $ ppr recv <+/> nest 2 (pprMsgArgs args) where pprMsgArgs ([ObjCArg (Just sel) Nothing loc]) = pprLoc loc $ ppr sel pprMsgArgs _ = sep (map pprMsgArg args) <> cat (map pprVarArg varArgs) pprMsgArg (ObjCArg (Just sel) (Just e) loc) = pprLoc loc $ ppr sel <> colon <+> ppr e pprMsgArg (ObjCArg Nothing (Just e) loc) = pprLoc loc $ colon <+> ppr e pprMsgArg (ObjCArg _ Nothing loc) = error $ "pretty printing 'ObjCArg': missing expression at " ++ show loc pprMsgArg (AntiObjCArg v _) = pprAnti "kwarg" v pprMsgArg (AntiObjCArgs v _) = pprAnti "kwargs" v pprVarArg e = comma <+> ppr e pprPrec _ (ObjCLitConst op c loc) = srcloc loc <> char '@' <> maybe empty ppr op <> ppr c pprPrec _ (ObjCLitString strs loc) = srcloc loc <> spread (map ((char '@' <>) . ppr) strs) pprPrec _ (ObjCLitBool False loc) = srcloc loc <> text "@NO" pprPrec _ (ObjCLitBool True loc) = srcloc loc <> text "@YES" pprPrec _ (ObjCLitArray es loc) = srcloc loc <> char '@' <> brackets (commasep (map ppr es)) pprPrec _ (ObjCLitDict as loc) = srcloc loc <> char '@' <> braces (commasep (map ppr as)) pprPrec _ (ObjCLitBoxed e loc) = srcloc loc <> char '@' <> parens (ppr e) pprPrec _ (ObjCEncode t loc) = srcloc loc <> text "@encode" <> parens (ppr t) pprPrec _ (ObjCProtocol ident loc) = srcloc loc <> text "@protocol" <> parens (ppr ident) pprPrec _ (ObjCSelector sel loc) = srcloc loc <> text "@selector" <> parens (text sel) pprPrec _ (Lambda captureList decl blockItems loc) = srcloc loc <> ppr captureList <> ppr decl <> ppr blockItems pprPrec _ (AntiArgs v _) = pprAnti "args" v pprPrec _ (AntiExp v _) = pprAnti "var" v instance Pretty LambdaDeclarator where pprPrec _ (LambdaDeclarator params isMutable returnType _) = parens (ppr params) <> (if isMutable then text "mutable" else empty) <> (if isJust returnType then text "->" <> ppr returnType else empty) instance Pretty LambdaIntroducer where pprPrec _ (LambdaIntroducer items loc) = pprLoc loc $ brackets $ commasep (map ppr items) instance Pretty CaptureListEntry where pprPrec _ DefaultByValue = char '=' pprPrec _ DefaultByReference = char '&' instance Pretty ObjCDictElem where pprPrec _ (ObjCDictElem l r _) = ppr l <+> colon <+> ppr r pprPrec _ (AntiObjCDictElems v _) = pprAnti "dictelems" v instance Pretty BinOp where ppr Add = text "+" ppr Sub = text "-" ppr Mul = text "*" ppr Div = text "/" ppr Mod = text "%" ppr Eq = text "==" ppr Ne = text "!=" ppr Lt = text "<" ppr Gt = text ">" ppr Le = text "<=" ppr Ge = text ">=" ppr Land = text "&&" ppr Lor = text "||" ppr And = text "&" ppr Or = text "|" ppr Xor = text "^" ppr Lsh = text "<<" ppr Rsh = text ">>" instance Pretty AssignOp where ppr JustAssign = text "=" ppr AddAssign = text "+=" ppr SubAssign = text "-=" ppr MulAssign = text "*=" ppr DivAssign = text "/=" ppr ModAssign = text "%=" ppr LshAssign = text "<<=" ppr RshAssign = text ">>=" ppr AndAssign = text "&=" ppr XorAssign = text "^=" ppr OrAssign = text "|=" instance Pretty UnOp where ppr AddrOf = text "&" ppr Deref = text "*" ppr Positive = text "+" ppr Negate = text "-" ppr Not = text "~" ppr Lnot = text "!" instance Pretty AsmOut where ppr (AsmOut Nothing constraint ident) = text constraint <+> parens (ppr ident) ppr (AsmOut (Just sym) constraint ident) = brackets (ppr sym) <+> text constraint <+> parens (ppr ident) pprList [] = empty pprList outs = commasep (map ppr outs) instance Pretty AsmIn where ppr (AsmIn Nothing constraint e) = text constraint <+> parens (ppr e) ppr (AsmIn (Just sym) constraint e) = brackets (ppr sym) <+> text constraint <+> parens (ppr e) pprList [] = empty pprList ins = commasep (map ppr ins) instance Pretty BlockType where ppr (BlockVoid _loc) = empty ppr (BlockParam params loc) = pprLoc loc $ parens (commasep (map ppr params)) ppr (BlockType ty loc) = pprLoc loc $ ppr ty instance Pretty ObjCIvarDecl where ppr (ObjCIvarVisi visi loc) = pprLoc loc $ ppr visi ppr (ObjCIvarDecl field loc) = pprLoc loc $ ppr field <> semi instance Pretty ObjCVisibilitySpec where ppr (ObjCPrivate _loc) = text "@private" ppr (ObjCPublic _loc) = text "@public" ppr (ObjCProtected _loc) = text "@protected" ppr (ObjCPackage _loc) = text "@package" instance Pretty ObjCIfaceDecl where ppr (ObjCIfaceProp attrs field loc) = pprLoc loc $ text "@property" <+> case attrs of [] -> empty _ -> parensList (map ppr attrs) <> space <> ppr field <> semi ppr (ObjCIfaceReq req loc) = pprLoc loc $ ppr req ppr (ObjCIfaceMeth proto _loc) = ppr proto <> semi ppr (ObjCIfaceDecl decl loc) = pprLoc loc $ ppr decl ppr (AntiObjCIfaceDecl v _loc) = pprAnti "ifdecl" v ppr (AntiObjCIfaceDecls v _loc) = pprAnti "ifdecls" v ppr (AntiObjCProp v _) = pprAnti "prop" v ppr (AntiObjCProps v _) = pprAnti "props" v instance Pretty ObjCPropAttr where ppr (ObjCGetter ident loc) = pprLoc loc $ text "getter=" <> ppr ident ppr (ObjCSetter ident loc) = pprLoc loc $ text "setter=" <> ppr ident <> colon ppr (ObjCReadonly loc) = pprLoc loc $ text "readonly" ppr (ObjCReadwrite loc) = pprLoc loc $ text "readwrite" ppr (ObjCAssign loc) = pprLoc loc $ text "assign" ppr (ObjCRetain loc) = pprLoc loc $ text "retain" ppr (ObjCCopy loc) = pprLoc loc $ text "copy" ppr (ObjCNonatomic loc) = pprLoc loc $ text "nonatomic" ppr (ObjCAtomic loc) = pprLoc loc $ text "atomic" ppr (ObjCStrong loc) = pprLoc loc $ text "strong" ppr (ObjCWeak loc) = pprLoc loc $ text "weak" ppr (ObjCUnsafeUnretained loc) = pprLoc loc $ text "unsafe_unretained" ppr (AntiObjCAttr v _) = pprAnti "propattr" v ppr (AntiObjCAttrs v _) = pprAnti "propattrs" v instance Pretty ObjCMethodReq where ppr (ObjCRequired _loc) = text "@required" ppr (ObjCOptional _loc) = text "@optional" instance Pretty ObjCParam where ppr (ObjCParam sel ty attrs arg loc) = pprLoc loc $ case (sel, arg) of (Nothing , Nothing) -> error $ "pretty printing 'ObjCParam': empty " ++ show loc (Just sid, Nothing) -> ppr sid (_ , Just pid) -> maybe empty ppr sel <> colon <> maybe empty (parens . ppr) ty <> ppr attrs <> ppr pid ppr (AntiObjCParam p _) = pprAnti "methparam" p ppr (AntiObjCParams v _) = pprAnti "methparams" v instance Pretty ObjCMethodProto where ppr (ObjCMethodProto isClassMeth resTy attrs1 params vargs attrs2 loc) = pprLoc loc $ (if isClassMeth then char '+' else char '-') <+> maybe empty (parens . ppr) resTy <+> ppr attrs1 <+> spread (map ppr params) <> (if vargs then text ", ..." else empty) <+> ppr attrs2 ppr (AntiObjCMethodProto p _) = pprAnti "methproto" p instance Pretty ObjCCatch where ppr (ObjCCatch Nothing block loc) = srcloc loc <> text "@catch (...)" <+> ppr block ppr (ObjCCatch (Just param) block loc) = srcloc loc <> text "@catch" <+> parens (ppr param) <+> ppr block pprList = stack . map ppr instance Pretty ObjCRecv where ppr (ObjCRecvSuper loc) = pprLoc loc $ text "super" ppr (ObjCRecvExp e loc) = pprLoc loc $ ppr e ppr (AntiObjCRecv v _) = pprAnti "recv" v language-c-quote-0.13.0.2/Language/C/Quote.hs0000644000000000000000000002325407346545000016626 0ustar0000000000000000-- | -- Module : Language.C.Quote -- Copyright : (c) 2010-2011 Harvard University -- (c) 2011-2013 Geoffrey Mainland -- : (c) 2013-2015 Drexel University -- License : BSD-style -- Maintainer : mainland@drexel.edu -- -- There are five modules that provide quasiquoters, each for a different C -- variant. 'Language.C.Quote.C' parses C99, 'Language.C.Quote.GCC' parses C99 -- plus GNU extensions, 'Language.C.Quote.CUDA' parses C99 plus GNU and CUDA -- extensions, 'Language.C.Quote.OpenCL' parses C99 plus GNU and OpenCL -- extensions and, 'Language.C.Quote.ObjC' parses C99 plus a subset of Objective-C -- -- For version of GHC prior to 7.4, the quasiquoters generate Template Haskell -- expressions that use data constructors that must be in scope where the -- quasiquoted expression occurs. You will be safe if you add the following -- imports to any module using the quasiquoters provided by this package: -- -- > import qualified Data.Loc -- > import qualified Language.C.Syntax -- -- These modules may also be imported unqualified, of course. The quasiquoters -- also use some constructors defined in the standard Prelude, so if it is not -- imported by default, it must be imported qualified. On GHC 7.4 and above, you -- can use the quasiquoters without worrying about what names are in scope. -- -- The following quasiquoters are defined: -- -- [@cdecl@] Declaration, of type @'InitGroup'@. -- -- [@cedecl@] External declarations (top-level declarations in a C file, -- including function definitions and declarations), of type @'Definition'@. -- -- [@cenum@] Component of an @enum@ definition, of type @'CEnum'@. -- -- [@cexp@] Expression, of type @'Exp'@. -- -- [@cstm@] Statement, of type @'Stm'@. -- -- [@cstms@] A list of statements, of type @['Stm']@. -- -- [@citem@] Block item, of type @'BlockItem'@. A block item is either a -- declaration or a statement. -- -- [@citems@] A list of block items, of type @['BlockItem']. -- -- [@cfun@] Function definition, of type @'Func'@. -- -- [@cinit@] Initializer, of type @'Initializer'@. -- -- [@cparam@] Declaration of a function parameter, of type @'Param'@. -- -- [@cparams@] Declaration of function parameters, of type @['Param']@. -- -- [@csdecl@] Declaration of a struct member, of type @'FieldGroup'@. -- -- [@ctyquals@] A list of type qualifiers, of type @['TyQual']@. -- -- [@cty@] A C type, of type @'Type'@. -- -- [@cunit@] A compilation unit, of type @['Definition']@. -- -- In addition, Objective-C support defines the following quasiquoters: -- -- [@objcprop@] Property declaration of type @'ObjCIfaceDecl'@. -- -- [@objcifdecls@] Interface declarations of type @['ObjCIfaceDecl']@ -- -- [@objcimdecls@] Class implementation declarations of type @['Definition']@ -- -- [@objcdictelem@] Dictionary element, of type @'ObjCDictElem'@ -- -- [@objcpropattr@] Property attribute element, of type @'ObjCPropAttr'@ -- -- [@objcmethparam@] Method parameter, of type @'ObjCParam'@ -- -- [@objcmethproto@] Method prototype, of type @'ObjCMethodProto'@ -- -- [@objcmethdef@] Method definition, of type @'Definition'@ -- -- [@objcrecv@] Receiver, of type @'ObjCRecv'@ -- -- [@objcarg@] Keyword argument, of type @'ObjCArg'@ -- -- -- Antiquotations allow splicing in subterms during quotation. These subterms -- may bound to a Haskell variable or may be the value of a Haskell -- expression. Antiquotations appear in a quasiquotation in the form -- @$ANTI:VARID@, where @ANTI@ is a valid antiquote specifier and @VARID@ is a -- Haskell variable identifier, or in the form @$ANTI:(EXP)@, where @EXP@ is a -- Haskell expressions (the parentheses must appear in this case). The Haskell -- expression may itself contain a quasiquote, but in that case the final @|]@ -- must be escaped as @\\|\\]@. Additionally, @$VARID@ is shorthand for -- @$exp:VARID@ and @$(EXP)@ is shorthand for @$exp:(EXP)@, i.e., @exp@ is the -- default antiquote specifier. -- -- It is often useful to use typedefs that aren't in scope when quasiquoting, -- e.g., @[cdecl|uint32_t foo;|]@. The quasiquoter will complain when it sees -- this because it thinks @uint32_t@ is an identifier. The solution is to use -- the @typename@ keyword, borrowed from C++, to tell the parser that the -- identifier is actually a type name. That is, we can write @[cdecl|typename -- uint32_t foo;|]@ to get the desired behavior. -- -- Valid antiquote specifiers are: -- -- [@id@] A C identifier. The argument must be an instance of @'ToIdent'@. -- -- [@comment@] A comment to be attached to a statement. The argument must have -- type @'String'@, and the antiquote must appear in a statement context. -- -- [@const@] A constant. The argument must be an instance of @'ToConst'@. -- -- [@int@] An @integer@ constant. The argument must be an instance of -- @'Integral'@. -- -- [@uint@] An @unsigned integer@ constant. The argument must be an instance of -- @'Integral'@. -- -- [@lint@] A @long integer@ constant. The argument must be an instance of -- @'Integral'@. -- -- [@ulint@] An @unsigned long integer@ constant. The argument must be an -- instance of @'Integral'@. -- -- [@llint@] A @long long integer@ constant. The argument must be an instance of -- @'Integral'@. -- -- [@ullint@] An @unsigned long long integer@ constant. The argument must be an -- instance of @'Integral'@. -- -- [@float@] A @float@ constant. The argument must be an instance of -- @'Fractional'@. -- -- [@double@] A @double@ constant. The argument must be an instance of -- @'Fractional'@. -- -- [@long double@] A @long double@ constant. The argument must be an instance -- of @'Fractional'@. -- -- [@char@] A @char@ constant. The argument must have type @'Char'@. -- -- [@string@] A string (@char*@) constant. The argument must have type -- @'String'@. -- -- [@exp@] A C expression. The argument must be an instance of @'ToExp'@. -- -- [@func@] A function definition. The argument must have type @'Func'@. -- -- [@args@] A list of function arguments. The argument must have type @['Exp']@. -- -- [@decl@] A declaration. The argument must have type @'InitGroup'@. -- -- [@decls@] A list of declarations. The argument must have type -- @['InitGroup']@. -- -- [@sdecl@] A struct member declaration. The argument must have type -- @'FieldGroup'@. -- -- [@sdecls@] A list of struct member declarations. The argument must have type -- @['FieldGroup']@. -- -- [@enum@] An enum member. The argument must have type @'CEnum'@. -- -- [@enums@] An list of enum members. The argument must have type @['CEnum']@. -- -- [@esc@] An arbitrary top-level C "definition," such as an @#include@ or a -- @#define@. The argument must have type @'String'@. Also: an uninterpreted, -- expression-level C escape hatch, which is useful for passing through macro -- calls. The argument must have type @'String'@. -- -- [@escstm@] An uninterpreted, statement-level C escape hatch, which is useful -- for passing through macro calls. The argument must have type @'String'@. -- -- [@edecl@] An external definition. The argument must have type @'Definition'@. -- -- [@edecls@] An list of external definitions. The argument must have type -- @['Definition']@. -- -- [@item@] A statement block item. The argument must have type @'BlockItem'@. -- -- [@items@] A list of statement block item. The argument must have type -- @['BlockItem']@. -- -- [@stm@] A statement. The argument must have type @'Stm'@. -- -- [@stms@] A list of statements. The argument must have type @['Stm']@. -- -- [@tyqual@] A type qualifier. The argument must have type @'TyQual'@. -- -- [@tyquals@] A list of type qualifiers. The argument must have type -- @['TyQual']@. -- -- [@ty@] A C type. The argument must have type @'Type'@. -- -- [@spec@] A declaration specifier. The argument must have type @'DeclSpec'@. -- -- [@param@] A function parameter. The argument must have type @'Param'@. -- -- [@params@] A list of function parameters. The argument must have type -- @['Param']@. -- -- [@pragma@] A pragma statement. The argument must have type @'String'@. -- -- [@init@] An initializer. The argument must have type @'Initializer'@. -- -- [@inits@] A list of initializers. The argument must have type -- @['Initializer']@. -- -- In addition, Objective-C code can use these antiquote specifiers: -- -- [@ifdecl@] A class interface declaration. The argument must have type -- @'ObjCIfaceDecl'@. -- -- [@ifdecls@] A list of class interface declaration. The argument must have -- type @['ObjCIfaceDecl']@. -- -- [@prop@] A property declaration. The argument must have type -- @'ObjCIfaceDecl'@. -- -- [@props@] A list of property declarations. The argument must have type -- @['ObjCIfaceDecl']@. -- -- [@propattr@] A property attribute. The argument must have type -- @'ObjCPropAttr'@. -- -- [@propattrs@] A list of property attribute. The argument must have type -- @['ObjCPropAttr']@. -- -- [@dictelems@] A list dictionary elements. The argument must have type -- @['ObjCDictElem']@. -- -- [@methparam@] A method parameter. The argument must have type -- @'ObjCParam'@. -- -- [@methparams@] A list of method parameters. The argument must have type -- @['ObjCParam']@. -- -- [@methproto@] A method prototype. The argument must have type -- @'ObjCMethodProto'@. -- -- [@methdef@] A method definition. The argument must have type -- @['Definition']@. -- -- [@methdefs@] A list of method definitions. The argument must have type -- @['Definition']@. -- -- [@recv@] A receiver. The argument must have type @'ObjCRecv'@. -- -- [@kwarg@] A keywords argument. The argument must have type -- @'ObjCArg'@. -- -- [@kwargs@] A list of keyword arguments. The argument must have type -- @['ObjCArg']@. -- -------------------------------------------------------------------------------- module Language.C.Quote ( module Language.C.Quote.Base, module Language.C.Syntax ) where import Language.C.Quote.Base import Language.C.Syntax language-c-quote-0.13.0.2/Language/C/Quote/0000755000000000000000000000000007346545000016264 5ustar0000000000000000language-c-quote-0.13.0.2/Language/C/Quote/Base.hs0000644000000000000000000007554307346545000017510 0ustar0000000000000000-- | -- Module : Language.C.Quote -- Copyright : (c) 2006-2011 Harvard University -- (c) 2011-2013 Geoffrey Mainland -- : (c) 2013-2017 Drexel University -- License : BSD-style -- Maintainer : mainland@drexel.edu {-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE TemplateHaskell #-} {-# OPTIONS_GHC -w #-} module Language.C.Quote.Base ( ToIdent(..), ToConst(..), ToExp(..), qqExp, qqPat, quasiquote ) where import Control.Monad ((>=>)) import qualified Data.ByteString.Char8 as B import Data.Char (isAscii, isPrint, ord) import Data.Data (Data(..)) import Data.Generics (extQ) import Data.Int import Data.Loc import Data.Typeable (Typeable(..)) import Data.Word #ifdef FULL_HASKELL_ANTIQUOTES import Language.Haskell.Meta (parseExp,parsePat) #else import Language.Haskell.ParseExp (parseExp,parsePat) #endif import Language.Haskell.TH as TH #if MIN_VERSION_template_haskell(2,7,0) import Language.Haskell.TH.Quote (QuasiQuoter(..), dataToQa, dataToExpQ, dataToPatQ) #else /* !MIN_VERSION_template_haskell(2,7,0) */ import Language.Haskell.TH.Quote (QuasiQuoter(..)) #endif /* !MIN_VERSION_template_haskell(2,7,0) */ import Language.Haskell.TH.Syntax import Numeric (showOct, showHex) import qualified Language.C.Parser as P import qualified Language.C.Syntax as C newtype LongDouble = LongDouble Double -- | An instance of 'ToIndent' can be converted to a 'C.Id'. class ToIdent a where toIdent :: a -> SrcLoc -> C.Id instance ToIdent C.Id where toIdent ident _ = ident instance ToIdent (SrcLoc -> C.Id) where toIdent ident = ident instance ToIdent String where toIdent s loc = C.Id s loc -- | An instance of 'ToConst' can be converted to a 'C.Const'. class ToConst a where toConst :: a -> SrcLoc -> C.Const instance ToConst C.Const where toConst k _ = k instance ToConst Int where toConst = toConst . toInteger instance ToConst Int8 where toConst = toConst . toInteger instance ToConst Int16 where toConst = toConst . toInteger instance ToConst Int32 where toConst = toConst . toInteger instance ToConst Int64 where toConst = toConst . toInteger instance ToConst Word where toConst n loc = C.IntConst (show n) C.Unsigned (toInteger n) loc instance ToConst Word8 where toConst n loc = C.IntConst (show n) C.Unsigned (toInteger n) loc instance ToConst Word16 where toConst n loc = C.IntConst (show n) C.Unsigned (toInteger n) loc instance ToConst Word32 where toConst n loc = C.IntConst (show n) C.Unsigned (toInteger n) loc instance ToConst Word64 where toConst n loc = C.IntConst (show n) C.Unsigned (toInteger n) loc instance ToConst Integer where toConst n loc = C.IntConst (show n) C.Signed n loc instance ToConst Rational where toConst n loc = toConst (fromRational n :: Double) loc instance ToConst Float where toConst n loc = C.FloatConst (realFloatToString n ++ "F") n loc instance ToConst Double where toConst n loc = C.DoubleConst (realFloatToString n) n loc instance ToConst LongDouble where toConst (LongDouble n) loc = C.LongDoubleConst (realFloatToString n ++ "L") n loc realFloatToString :: (RealFloat a, Show a) => a -> String realFloatToString n | isNaN n = "NAN" | isInfinite n = if n < 0 then "-INFINITY" else "INFINITY" | otherwise = show n instance ToConst Char where toConst c loc = C.CharConst ("'" ++ charToString c ++ "'") c loc where charToString :: Char -> String charToString '\0' = "\\0" charToString '\a' = "\\a" charToString '\b' = "\\b" charToString '\f' = "\\f" charToString '\n' = "\\n" charToString '\r' = "\\r" charToString '\t' = "\\t" charToString '\v' = "\\v" charToString '\\' = "\\\\" charToString '\"' = "\\\"" charToString c | isAscii c && isPrint c = [c] | isAscii c = "\\x" ++ hexOf Nothing c | ord c < 0x10000 = "\\u" ++ hexOf (Just 4) c | otherwise = "\\U" ++ hexOf (Just 8) c where hexOf :: Maybe Int -> Char -> String hexOf len c = case len of Nothing -> hex Just i -> replicate (i - length hex) '0' ++ hex where hex :: String hex = showHex (ord c) "" instance ToConst String where toConst s loc = C.StringConst [show s] s loc -- | An instance of 'ToExp' can be converted to a 'C.Exp'. class ToExp a where toExp :: a -> SrcLoc -> C.Exp instance ToExp C.Exp where toExp e _ = e instance ToExp Int where toExp n loc = C.Const (toConst n loc) loc instance ToExp Int8 where toExp n loc = C.Const (toConst n loc) loc instance ToExp Int16 where toExp n loc = C.Const (toConst n loc) loc instance ToExp Int32 where toExp n loc = C.Const (toConst n loc) loc instance ToExp Int64 where toExp n loc = C.Const (toConst n loc) loc instance ToExp Word where toExp n loc = C.Const (toConst n loc) loc instance ToExp Word8 where toExp n loc = C.Const (toConst n loc) loc instance ToExp Word16 where toExp n loc = C.Const (toConst n loc) loc instance ToExp Word32 where toExp n loc = C.Const (toConst n loc) loc instance ToExp Word64 where toExp n loc = C.Const (toConst n loc) loc instance ToExp Integer where toExp n loc = C.Const (toConst n loc) loc instance ToExp Rational where toExp n loc = C.Const (toConst n loc) loc instance ToExp Float where toExp n loc = C.Const (toConst n loc) loc instance ToExp Double where toExp n loc = C.Const (toConst n loc) loc instance ToExp Char where toExp n loc = C.Const (toConst n loc) loc instance ToExp String where toExp n loc = C.Const (toConst n loc) loc antiVarE :: String -> ExpQ antiVarE = either fail return . parseExp qqLocE :: SrcLoc -> ExpQ qqLocE loc = dataToExpQ qqExp loc qqStringE :: String -> Maybe (Q Exp) qqStringE s = Just $ litE $ stringL s qqIdE :: C.Id -> Maybe (Q Exp) qqIdE (C.AntiId v loc) = Just [|toIdent $(antiVarE v) $(qqLocE loc)|] qqIdE _ = Nothing qqDeclSpecE :: C.DeclSpec -> Maybe (Q Exp) qqDeclSpecE (C.AntiDeclSpec v _) = Just $ antiVarE v qqDeclSpecE (C.AntiTypeDeclSpec extraStorage extraTypeQuals v _) = Just [| case $(antiVarE v) of C.Type (C.DeclSpec storage typeQuals typeSpec loc) _ _ -> C.DeclSpec (storage ++ $(dataToExpQ qqExp extraStorage)) (typeQuals ++ $(dataToExpQ qqExp extraTypeQuals)) typeSpec loc x -> error $ "Impossible happened, expected C.Type (C.DeclSpec {}) but got " ++ show x |] qqDeclSpecE _ = Nothing qqDeclE :: C.Decl -> Maybe (Q Exp) qqDeclE (C.AntiTypeDecl v _) = Just [| case $(antiVarE v) of C.Type _ decl _ -> decl x -> error $ "Impossible happened, expected C.Type but got " ++ show x |] qqDeclE _ = Nothing qqTypeQualE :: C.TypeQual -> Maybe (Q Exp) qqTypeQualE (C.AntiTypeQual v _) = Just $ antiVarE v qqTypeQualE _ = Nothing qqTypeQualListE :: [C.TypeQual] -> Maybe (Q Exp) qqTypeQualListE [] = Just [|[]|] qqTypeQualListE (C.AntiTypeQuals v _ : stms) = Just [|$(antiVarE v) ++ $(dataToExpQ qqExp stms)|] qqTypeQualListE (stm : stms) = Just [|$(dataToExpQ qqExp stm) : $(dataToExpQ qqExp stms)|] qqTypeE :: C.Type -> Maybe (Q Exp) qqTypeE (C.AntiType v _) = Just $ antiVarE v qqTypeE _ = Nothing qqInitializerE :: C.Initializer -> Maybe (Q Exp) qqInitializerE (C.AntiInit v _) = Just $ antiVarE v qqInitializerE _ = Nothing qqInitializerListE :: [(Maybe C.Designation, C.Initializer)] -> Maybe (Q Exp) qqInitializerListE [] = Just [|[]|] qqInitializerListE ((Nothing, C.AntiInits v _) : fields) = Just [|[(Nothing, init) | init <- $(antiVarE v)] ++ $(dataToExpQ qqExp fields)|] qqInitializerListE (field : fields) = Just [|$(dataToExpQ qqExp field) : $(dataToExpQ qqExp fields)|] qqInitGroupE :: C.InitGroup -> Maybe (Q Exp) qqInitGroupE (C.AntiDecl v _) = Just $ antiVarE v qqInitGroupE _ = Nothing qqInitGroupListE :: [C.InitGroup] -> Maybe (Q Exp) qqInitGroupListE [] = Just [|[]|] qqInitGroupListE (C.AntiDecls v _ : inits) = Just [|$(antiVarE v) ++ $(dataToExpQ qqExp inits)|] qqInitGroupListE (ini : inis) = Just [|$(dataToExpQ qqExp ini) : $(dataToExpQ qqExp inis)|] qqAttrE :: C.Attr -> Maybe (Q Exp) qqAttrE (C.AntiAttr v _) = Just $ antiVarE v qqAttrE _ = Nothing qqAttrListE :: [C.Attr] -> Maybe (Q Exp) qqAttrListE [] = Just [|[]|] qqAttrListE (C.AntiAttrs v _ : attrs) = Just [|$(antiVarE v) ++ $(dataToExpQ qqExp attrs)|] qqAttrListE (field : fields) = Just [|$(dataToExpQ qqExp field) : $(dataToExpQ qqExp fields)|] qqFieldGroupE :: C.FieldGroup -> Maybe (Q Exp) qqFieldGroupE (C.AntiSdecl v _) = Just $ antiVarE v qqFieldGroupE _ = Nothing qqFieldGroupListE :: [C.FieldGroup] -> Maybe (Q Exp) qqFieldGroupListE [] = Just [|[]|] qqFieldGroupListE (C.AntiSdecls v _ : fields) = Just [|$(antiVarE v) ++ $(dataToExpQ qqExp fields)|] qqFieldGroupListE (field : fields) = Just [|$(dataToExpQ qqExp field) : $(dataToExpQ qqExp fields)|] qqCEnumE :: C.CEnum -> Maybe (Q Exp) qqCEnumE (C.AntiEnum v _) = Just $ antiVarE v qqCEnumE _ = Nothing qqCEnumListE :: [C.CEnum] -> Maybe (Q Exp) qqCEnumListE [] = Just [|[]|] qqCEnumListE (C.AntiEnums v _ : fields) = Just [|$(antiVarE v) ++ $(dataToExpQ qqExp fields)|] qqCEnumListE (field : fields) = Just [|$(dataToExpQ qqExp field) : $(dataToExpQ qqExp fields)|] qqParamE :: C.Param -> Maybe (Q Exp) qqParamE (C.AntiParam v _) = Just $ antiVarE v qqParamE _ = Nothing qqParamListE :: [C.Param] -> Maybe (Q Exp) qqParamListE [] = Just [|[]|] qqParamListE (C.AntiParams v _ : args) = Just [|$(antiVarE v) ++ $(dataToExpQ qqExp args)|] qqParamListE (arg : args) = Just [|$(dataToExpQ qqExp arg) : $(dataToExpQ qqExp args)|] qqDefinitionE :: C.Definition -> Maybe (Q Exp) qqDefinitionE (C.AntiFunc v loc) = Just [|C.FuncDef $(antiVarE v) $(qqLocE loc)|] qqDefinitionE (C.AntiEsc v loc) = Just [|C.EscDef $(antiVarE v) $(qqLocE loc)|] qqDefinitionE (C.AntiEdecl v _) = Just $ antiVarE v qqDefinitionE (C.AntiObjCMeth m _) = Just $ antiVarE m qqDefinitionE _ = Nothing qqDefinitionListE :: [C.Definition] -> Maybe (Q Exp) qqDefinitionListE [] = Just [|[]|] qqDefinitionListE (C.AntiEdecls v _ : defs) = Just [|$(antiVarE v) ++ $(dataToExpQ qqExp defs)|] qqDefinitionListE (C.AntiObjCMeths m _ : meths) = Just [|$(antiVarE m) ++ $(dataToExpQ qqExp meths)|] qqDefinitionListE (def : defs) = Just [|$(dataToExpQ qqExp def) : $(dataToExpQ qqExp defs)|] qqConstE :: C.Const -> Maybe (Q Exp) qqConstE = go where go (C.AntiConst v loc) = Just [|toConst $(antiVarE v) $(qqLocE loc) :: C.Const|] go (C.AntiInt v loc) = Just [|C.IntConst $(intConst (antiVarE v)) C.Signed (fromIntegral $(antiVarE v)) $(qqLocE loc)|] go (C.AntiUInt v loc) = Just [|C.IntConst ($(intConst (antiVarE v)) ++ "U") C.Unsigned (fromIntegral $(antiVarE v)) $(qqLocE loc)|] go (C.AntiLInt v loc) = Just [|C.LongIntConst ($(intConst (antiVarE v)) ++ "L") C.Signed (fromIntegral $(antiVarE v)) $(qqLocE loc)|] go (C.AntiULInt v loc) = Just [|C.LongIntConst ($(intConst (antiVarE v)) ++ "UL") C.Unsigned (fromIntegral $(antiVarE v)) $(qqLocE loc)|] go (C.AntiLLInt v loc) = Just [|C.LongLongIntConst ($(intConst (antiVarE v)) ++ "LL") C.Signed (fromIntegral $(antiVarE v)) $(qqLocE loc)|] go (C.AntiULLInt v loc) = Just [|C.LongLongIntConst ($(intConst (antiVarE v)) ++ "ULL") C.Unsigned (fromIntegral $(antiVarE v)) $(qqLocE loc)|] go (C.AntiFloat v loc) = Just [|toConst ($(antiVarE v) :: Float) $(qqLocE loc)|] go (C.AntiDouble v loc) = Just [|toConst ($(antiVarE v) :: Double) $(qqLocE loc)|] go (C.AntiLongDouble v loc) = Just [|toConst (LongDouble $(antiVarE v)) $(qqLocE loc)|] go (C.AntiChar v loc) = Just [|toConst $(antiVarE v) $(qqLocE loc)|] go (C.AntiString v loc) = Just [|C.StringConst [show $(antiVarE v)] $(antiVarE v) $(qqLocE loc)|] go _ = Nothing intConst :: ExpQ -> ExpQ intConst e = [|show $(e)|] qqExpE :: C.Exp -> Maybe (Q Exp) qqExpE (C.AntiExp v loc) = Just [|toExp $(antiVarE v) $(qqLocE loc) :: C.Exp|] qqExpE (C.AntiEscExp v loc) = Just [|C.EscExp $(antiVarE v) $(qqLocE loc) :: C.Exp|] qqExpE _ = Nothing qqExpListE :: [C.Exp] -> Maybe (Q Exp) qqExpListE [] = Just [|[]|] qqExpListE (C.AntiArgs v loc : exps) = Just [|[toExp v $(qqLocE loc) | v <- $(antiVarE v)] ++ $(dataToExpQ qqExp exps)|] qqExpListE (exp : exps) = Just [|$(dataToExpQ qqExp exp) : $(dataToExpQ qqExp exps)|] qqStmE :: C.Stm -> Maybe (Q Exp) qqStmE (C.AntiEscStm v loc) = Just [|C.EscStm $(antiVarE v) $(qqLocE loc)|] qqStmE (C.AntiPragma v loc) = Just [|C.Pragma $(antiVarE v) $(qqLocE loc)|] qqStmE (C.AntiComment v stm loc) = Just [|C.Comment $(antiVarE v) $(dataToExpQ qqExp stm) $(qqLocE loc)|] qqStmE (C.AntiStm v _) = Just $ antiVarE v qqStmE _ = Nothing qqStmListE :: [C.Stm] -> Maybe (Q Exp) qqStmListE [] = Just [|[]|] qqStmListE (C.AntiStms v _ : stms) = Just [|$(antiVarE v) ++ $(dataToExpQ qqExp stms)|] qqStmListE (stm : stms) = Just [|$(dataToExpQ qqExp stm) : $(dataToExpQ qqExp stms)|] qqBlockItemE :: C.BlockItem -> Maybe (Q Exp) qqBlockItemE (C.AntiBlockItem v _) = Just $ antiVarE v qqBlockItemE _ = Nothing qqBlockItemListE :: [C.BlockItem] -> Maybe (Q Exp) qqBlockItemListE [] = Just [|[]|] qqBlockItemListE (C.BlockDecl (C.AntiDecls v _) : items) = Just [|map C.BlockDecl $(antiVarE v) ++ $(dataToExpQ qqExp items)|] qqBlockItemListE (C.BlockStm (C.AntiStms v _) : items) = Just [|map C.BlockStm $(antiVarE v) ++ $(dataToExpQ qqExp items)|] qqBlockItemListE (C.AntiBlockItems v _ : items) = Just [|$(antiVarE v) ++ $(dataToExpQ qqExp items)|] qqBlockItemListE (stm : stms) = Just [|$(dataToExpQ qqExp stm) : $(dataToExpQ qqExp stms)|] qqObjcIfaceDeclE :: C.ObjCIfaceDecl -> Maybe (Q Exp) qqObjcIfaceDeclE (C.AntiObjCProp p _) = Just $ antiVarE p qqObjcIfaceDeclE _ = Nothing qqObjcIfaceDeclListE :: [C.ObjCIfaceDecl] -> Maybe (Q Exp) qqObjcIfaceDeclListE [] = Just [|[]|] qqObjcIfaceDeclListE (C.AntiObjCProps p _ : decls) = Just [|$(antiVarE p) ++ $(dataToExpQ qqExp decls)|] qqObjcIfaceDeclListE (C.AntiObjCIfaceDecls v _ : decls) = Just [|$(antiVarE v) ++ $(dataToExpQ qqExp decls)|] qqObjcIfaceDeclListE (C.AntiObjCIfaceDecl v _ : decls) = Just [|$(antiVarE v) : $(dataToExpQ qqExp decls)|] qqObjcIfaceDeclListE (decl : decls) = Just [|$(dataToExpQ qqExp decl) : $(dataToExpQ qqExp decls)|] qqObjCPropAttrE :: C.ObjCPropAttr -> Maybe (Q Exp) qqObjCPropAttrE (C.AntiObjCAttr pa _) = Just $ antiVarE pa qqObjCPropAttrE _ = Nothing qqObjCPropAttrListE :: [C.ObjCPropAttr] -> Maybe (Q Exp) qqObjCPropAttrListE [] = Just [|[]|] qqObjCPropAttrListE (C.AntiObjCAttrs pa _:attrelems) = Just [|$(antiVarE pa) ++ $(dataToExpQ qqExp attrelems)|] qqObjCPropAttrListE (pattr : pattrs) = Just [|$(dataToExpQ qqExp pattr) : $(dataToExpQ qqExp pattrs)|] qqObjCDictsE :: [C.ObjCDictElem] -> Maybe (Q Exp) qqObjCDictsE [] = Just [|[]|] qqObjCDictsE (C.AntiObjCDictElems e _:elems) = Just [|$(antiVarE e) ++ $(dataToExpQ qqExp elems)|] qqObjCDictsE (elem : elems) = Just [|$(dataToExpQ qqExp elem) : $(dataToExpQ qqExp elems)|] qqObjCParamE :: C.ObjCParam -> Maybe (Q Exp) qqObjCParamE (C.AntiObjCParam p _) = Just $ antiVarE p qqObjCParamE _ = Nothing qqObjCParamsE :: [C.ObjCParam] -> Maybe (Q Exp) qqObjCParamsE [] = Just [|[]|] qqObjCParamsE (C.AntiObjCParams p _: props) = Just [|$(antiVarE p) ++ $(dataToExpQ qqExp props)|] qqObjCParamsE (param : params) = Just [|$(dataToExpQ qqExp param) : $(dataToExpQ qqExp params)|] qqObjCMethodProtoE :: C.ObjCMethodProto -> Maybe (Q Exp) qqObjCMethodProtoE (C.AntiObjCMethodProto p _) = Just $ antiVarE p qqObjCMethodProtoE _ = Nothing qqObjCRecvE :: C.ObjCRecv -> Maybe (Q Exp) qqObjCRecvE (C.AntiObjCRecv p _) = Just $ antiVarE p qqObjCRecvE _ = Nothing qqObjCArgE :: C.ObjCArg -> Maybe (Q Exp) qqObjCArgE (C.AntiObjCArg p _) = Just $ antiVarE p qqObjCArgE _ = Nothing qqObjCArgsE :: [C.ObjCArg] -> Maybe (Q Exp) qqObjCArgsE [] = Just [|[]|] qqObjCArgsE (C.AntiObjCArgs a _: args) = Just [|$(antiVarE a) ++ $(dataToExpQ qqExp args)|] qqObjCArgsE (arg : args) = Just [|$(dataToExpQ qqExp arg) : $(dataToExpQ qqExp args)|] qqExp :: Typeable a => a -> Maybe (Q Exp) qqExp = const Nothing `extQ` qqStringE `extQ` qqIdE `extQ` qqDeclSpecE `extQ` qqDeclE `extQ` qqTypeQualE `extQ` qqTypeQualListE `extQ` qqTypeE `extQ` qqInitializerE `extQ` qqInitializerListE `extQ` qqInitGroupE `extQ` qqInitGroupListE `extQ` qqAttrE `extQ` qqAttrListE `extQ` qqFieldGroupE `extQ` qqFieldGroupListE `extQ` qqCEnumE `extQ` qqCEnumListE `extQ` qqParamE `extQ` qqParamListE `extQ` qqDefinitionE `extQ` qqDefinitionListE `extQ` qqConstE `extQ` qqExpE `extQ` qqExpListE `extQ` qqStmE `extQ` qqStmListE `extQ` qqBlockItemE `extQ` qqBlockItemListE `extQ` qqObjcIfaceDeclE `extQ` qqObjcIfaceDeclListE `extQ` qqObjCPropAttrE `extQ` qqObjCPropAttrListE `extQ` qqObjCDictsE `extQ` qqObjCParamE `extQ` qqObjCParamsE `extQ` qqObjCMethodProtoE `extQ` qqObjCRecvE `extQ` qqObjCArgE `extQ` qqObjCArgsE antiVarP :: String -> PatQ antiVarP = either fail return . parsePat qqStringP :: String -> Maybe (Q Pat) qqStringP s = Just $ litP $ stringL s qqLocP :: Data.Loc.Loc -> Maybe (Q Pat) qqLocP _ = Just wildP qqIdP :: C.Id -> Maybe (Q Pat) qqIdP (C.AntiId v _) = Just $ conP (mkName "C.Id") [antiVarP v, wildP] qqIdP _ = Nothing qqDeclSpecP :: C.DeclSpec -> Maybe (Q Pat) qqDeclSpecP (C.AntiDeclSpec v _) = Just $ antiVarP v qqDeclSpecP C.AntiTypeDeclSpec{} = error "Illegal antiquoted type in pattern" qqDeclSpecP _ = Nothing qqDeclP :: C.Decl -> Maybe (Q Pat) qqDeclP C.AntiTypeDecl{} = error "Illegal antiquoted type in pattern" qqDeclP _ = Nothing qqTypeQualP :: C.TypeQual -> Maybe (Q Pat) qqTypeQualP (C.AntiTypeQual v _) = Just $ antiVarP v qqTypeQualP _ = Nothing qqTypeQualListP :: [C.TypeQual] -> Maybe (Q Pat) qqTypeQualListP [] = Just $ listP [] qqTypeQualListP [C.AntiTypeQuals v _] = Just $ antiVarP v qqTypeQualListP (C.AntiTypeQuals{} : _ : _) = error "Antiquoted list of type qualifiers must be last item in quoted list" qqTypeQualListP (arg : args) = Just $ conP (mkName ":") [dataToPatQ qqPat arg, dataToPatQ qqPat args] qqTypeP :: C.Type -> Maybe (Q Pat) qqTypeP (C.AntiType v _) = Just $ antiVarP v qqTypeP _ = Nothing qqInitializerP :: C.Initializer -> Maybe (Q Pat) qqInitializerP (C.AntiInit v _) = Just $ antiVarP v qqInitializerP _ = Nothing qqInitializerListP :: [C.Initializer] -> Maybe (Q Pat) qqInitializerListP [] = Just $ listP [] qqInitializerListP [C.AntiInits v _] = Just $ antiVarP v qqInitializerListP (C.AntiInits{} : _ : _) = error "Antiquoted list of initializers must be last item in quoted list" qqInitializerListP (ini : inis) = Just $ conP (mkName ":") [dataToPatQ qqPat ini, dataToPatQ qqPat inis] qqInitGroupP :: C.InitGroup -> Maybe (Q Pat) qqInitGroupP (C.AntiDecl v _) = Just $ antiVarP v qqInitGroupP _ = Nothing qqInitGroupListP :: [C.InitGroup] -> Maybe (Q Pat) qqInitGroupListP [] = Just $ listP [] qqInitGroupListP [C.AntiDecls v _] = Just $ antiVarP v qqInitGroupListP (C.AntiDecls{} : _ : _) = error "Antiquoted list of initialization groups must be last item in quoted list" qqInitGroupListP (ini : inis) = Just $ conP (mkName ":") [dataToPatQ qqPat ini, dataToPatQ qqPat inis] qqAttrP :: C.Attr -> Maybe (Q Pat) qqAttrP (C.AntiAttr v _) = Just $ antiVarP v qqAttrP _ = Nothing qqAttrListP :: [C.Attr] -> Maybe (Q Pat) qqAttrListP [] = Just $ listP [] qqAttrListP [C.AntiAttrs v _] = Just $ antiVarP v qqAttrListP (C.AntiAttrs{} : _ : _) = error "Antiquoted list of attrs must be last item in quoted list" qqAttrListP (ini : inis) = Just $ conP (mkName ":") [dataToPatQ qqPat ini, dataToPatQ qqPat inis] qqFieldGroupP :: C.FieldGroup -> Maybe (Q Pat) qqFieldGroupP (C.AntiSdecl v _) = Just $ antiVarP v qqFieldGroupP _ = Nothing qqFieldGroupListP :: [C.FieldGroup] -> Maybe (Q Pat) qqFieldGroupListP [] = Just $ listP [] qqFieldGroupListP [C.AntiSdecls v _] = Just $ antiVarP v qqFieldGroupListP (C.AntiSdecls{} : _ : _) = error "Antiquoted list of struct/union fields must be last item in quoted list" qqFieldGroupListP (ini : inis) = Just $ conP (mkName ":") [dataToPatQ qqPat ini, dataToPatQ qqPat inis] qqCEnumP :: C.CEnum -> Maybe (Q Pat) qqCEnumP (C.AntiEnum v _) = Just $ antiVarP v qqCEnumP _ = Nothing qqCEnumListP :: [C.CEnum] -> Maybe (Q Pat) qqCEnumListP [] = Just $ listP [] qqCEnumListP [C.AntiEnums v _] = Just $ antiVarP v qqCEnumListP (C.AntiEnums{} : _ : _) = error "Antiquoted list of enumerations must be last item in quoted list" qqCEnumListP (ini : inis) = Just $ conP (mkName ":") [dataToPatQ qqPat ini, dataToPatQ qqPat inis] qqParamP :: C.Param -> Maybe (Q Pat) qqParamP (C.AntiParam v _) = Just $ antiVarP v qqParamP _ = Nothing qqParamListP :: [C.Param] -> Maybe (Q Pat) qqParamListP [] = Just $ listP [] qqParamListP [C.AntiParams v _] = Just $ antiVarP v qqParamListP (C.AntiParams{} : _ : _) = error "Antiquoted list of parameters must be last item in quoted list" qqParamListP (arg : args) = Just $ conP (mkName ":") [dataToPatQ qqPat arg, dataToPatQ qqPat args] qqDefinitionP :: C.Definition -> Maybe (Q Pat) qqDefinitionP (C.AntiFunc v _) = Just $ conP (mkName "C.FuncDef") [antiVarP v, wildP] qqDefinitionP (C.AntiEsc v _) = Just $ conP (mkName "C.EscDef") [antiVarP v, wildP] qqDefinitionP (C.AntiEdecl v _) = Just $ antiVarP v qqDefinitionP _ = Nothing qqDefinitionListP :: [C.Definition] -> Maybe (Q Pat) qqDefinitionListP [] = Just $ listP [] qqDefinitionListP [C.AntiEdecls v _] = Just $ antiVarP v qqDefinitionListP (C.AntiEdecls{} : _ : _) = error "Antiquoted list of definitions must be last item in quoted list" qqDefinitionListP (arg : args) = Just $ conP (mkName ":") [dataToPatQ qqPat arg, dataToPatQ qqPat args] qqConstP :: C.Const -> Maybe (Q Pat) qqConstP = go where go (C.AntiInt v _) = Just $ con "C.IntConst" [wildP, signed, antiVarP v, wildP] go (C.AntiUInt v _) = Just $ con "C.IntConst" [wildP, unsigned, antiVarP v, wildP] go (C.AntiLInt v _) = Just $ con "C.LongIntConst" [wildP, signed, antiVarP v, wildP] go (C.AntiULInt v _) = Just $ con "C.LongIntConst" [wildP, unsigned, antiVarP v, wildP] go (C.AntiFloat v _) = Just $ con "C.FloatConst" [wildP, antiVarP v, wildP] go (C.AntiDouble v _) = Just $ con "C.DoubleConst" [wildP, antiVarP v, wildP] go (C.AntiLongDouble v _) = Just $ con "C.LongDoubleConst" [wildP, antiVarP v, wildP] go (C.AntiChar v _) = Just $ con "C.CharConst" [wildP, antiVarP v, wildP] go (C.AntiString v _) = Just $ con "C.StringConst" [wildP, antiVarP v, wildP] go _ = Nothing con n = conP (mkName n) signed = conP (mkName "C.Signed") [] unsigned = conP (mkName "C.Unsigned") [] qqExpP :: C.Exp -> Maybe (Q Pat) qqExpP (C.AntiExp v _) = Just $ antiVarP v qqExpP (C.AntiEscExp v _) = Just $ conP (mkName "C.EscExp") [antiVarP v, wildP] qqExpP _ = Nothing qqExpListP :: [C.Exp] -> Maybe (Q Pat) qqExpListP [] = Just $ listP [] qqExpListP [C.AntiArgs v _] = Just $ antiVarP v qqExpListP (C.AntiArgs{} : _ : _) = error "Antiquoted list of arguments must be last item in quoted list" qqExpListP (arg : args) = Just $ conP (mkName ":") [dataToPatQ qqPat arg, dataToPatQ qqPat args] qqStmP :: C.Stm -> Maybe (Q Pat) qqStmP (C.AntiStm v _) = Just $ antiVarP v qqStmP (C.AntiEscStm v _) = Just $ conP (mkName "C.EscStm") [antiVarP v, wildP] qqStmP _ = Nothing qqStmListP :: [C.Stm] -> Maybe (Q Pat) qqStmListP [] = Just $ listP [] qqStmListP [C.AntiStms v _] = Just $ antiVarP v qqStmListP (C.AntiStms{} : _ : _) = error "Antiquoted list of statements must be last item in quoted list" qqStmListP (arg : args) = Just $ conP (mkName ":") [dataToPatQ qqPat arg, dataToPatQ qqPat args] qqBlockItemP :: C.BlockItem -> Maybe (Q Pat) qqBlockItemP (C.AntiBlockItem v _) = Just $ antiVarP v qqBlockItemP _ = Nothing qqBlockItemListP :: [C.BlockItem] -> Maybe (Q Pat) qqBlockItemListP [] = Just $ listP [] qqBlockItemListP (C.BlockDecl C.AntiDecls{} : _) = error "Antiquoted list of declarations cannot appear in block" qqBlockItemListP (C.BlockStm C.AntiStms{} : _) = error "Antiquoted list of statements cannot appear in block" qqBlockItemListP [C.AntiBlockItems v _] = Just $ antiVarP v qqBlockItemListP (C.AntiBlockItems{} : _ : _) = error "Antiquoted list of block items must be last item in quoted list" qqBlockItemListP (arg : args) = Just $ conP (mkName ":") [dataToPatQ qqPat arg, dataToPatQ qqPat args] qqPat :: Typeable a => a -> Maybe (Q Pat) qqPat = const Nothing `extQ` qqStringP `extQ` qqLocP `extQ` qqIdP `extQ` qqDeclSpecP `extQ` qqDeclP `extQ` qqTypeQualP `extQ` qqTypeQualListP `extQ` qqTypeP `extQ` qqInitializerP `extQ` qqInitializerListP `extQ` qqInitGroupP `extQ` qqInitGroupListP `extQ` qqAttrP `extQ` qqAttrListP `extQ` qqFieldGroupP `extQ` qqCEnumP `extQ` qqCEnumListP `extQ` qqParamP `extQ` qqParamListP `extQ` qqDefinitionP `extQ` qqDefinitionListP `extQ` qqConstP `extQ` qqExpP `extQ` qqExpListP `extQ` qqStmP `extQ` qqStmListP `extQ` qqBlockItemP `extQ` qqBlockItemListP parse :: [C.Extensions] -> [String] -> P.P a -> String -> Q a parse exts typenames p s = do loc <- location case P.parse (C.Antiquotation : exts) typenames p (B.pack s) (Just (locToPos loc)) of Left err -> fail (show err) Right x -> return x where locToPos :: TH.Loc -> Pos locToPos TH.Loc {loc_filename = filename, loc_start = (line, col)} = Pos filename line col 0 quasiquote :: Data a => [C.Extensions] -> [String] -> P.P a -> QuasiQuoter quasiquote exts typenames p = QuasiQuoter { quoteExp = parse exts typenames p >=> dataToExpQ qqExp , quotePat = parse exts typenames p >=> dataToPatQ qqPat , quoteType = error "C type quasiquoter undefined" , quoteDec = error "C declaration quasiquoter undefined" } #if !MIN_VERSION_template_haskell(2,7,0) dataToQa :: forall a k q. Data a => (Name -> k) -> (Lit -> Q q) -> (k -> [Q q] -> Q q) -> (forall b . Data b => b -> Maybe (Q q)) -> a -> Q q dataToQa mkCon mkLit appCon antiQ t = case antiQ t of Nothing -> case constrRep constr of AlgConstr _ -> appCon con conArgs IntConstr n -> mkLit $ integerL n FloatConstr n -> mkLit $ rationalL (toRational n) CharConstr c -> mkLit $ charL c where constr :: Constr constr = toConstr t con :: k con = mkCon (mkConName mod occ) where mod :: String mod = (tyconModule . dataTypeName . dataTypeOf) t occ :: String occ = showConstr constr mkConName :: String -> String -> Name mkConName "Prelude" "(:)" = Name (mkOccName ":") NameS mkConName "Prelude" "[]" = Name (mkOccName "[]") NameS mkConName "Prelude" "()" = Name (mkOccName "()") NameS mkConName "Prelude" s@('(' : ',' : rest) = go rest where go :: String -> Name go (',' : rest) = go rest go ")" = Name (mkOccName s) NameS go _ = Name (mkOccName occ) (NameQ (mkModName mod)) mkConName "GHC.Real" ":%" = mkNameG_d "base" "GHC.Real" ":%" mkConName mod occ = Name (mkOccName occ) (NameQ (mkModName mod)) conArgs :: [Q q] conArgs = gmapQ (dataToQa mkCon mkLit appCon antiQ) t Just y -> y -- | 'dataToExpQ' converts a value to a 'Q Exp' representation of the same -- value. It takes a function to handle type-specific cases. dataToExpQ :: Data a => (forall b . Data b => b -> Maybe (Q Exp)) -> a -> Q Exp dataToExpQ = dataToQa conE litE (foldl appE) -- | 'dataToPatQ' converts a value to a 'Q Pat' representation of the same -- value. It takes a function to handle type-specific cases. dataToPatQ :: Data a => (forall b . Data b => b -> Maybe (Q Pat)) -> a -> Q Pat dataToPatQ = dataToQa id litP conP #endif /* !MIN_VERSION_template_haskell(2,7,0) */ language-c-quote-0.13.0.2/Language/C/Quote/C.hs0000644000000000000000000000333607346545000017007 0ustar0000000000000000-- | -- Module : Language.C.Quote.C -- Copyright : (c) 2006-2011 Harvard University -- (c) 2011-2013 Geoffrey Mainland -- : (c) 2013-2015 Drexel University -- License : BSD-style -- Maintainer : mainland@drexel.edu module Language.C.Quote.C ( ToIdent(..), ToConst(..), ToExp(..), cexp, cedecl, cdecl, csdecl, cenum, ctyquals, cty, cparam, cparams, cinit, cstm, cstms, citem, citems, cunit, cfun ) where import qualified Language.C.Parser as P import qualified Language.C.Syntax as C import Language.C.Quote.Base (ToIdent(..), ToConst(..), ToExp(..), quasiquote) import Language.Haskell.TH.Quote (QuasiQuoter) exts :: [C.Extensions] exts = [] typenames :: [String] typenames = [] cdecl, cedecl, cenum, cexp, cfun, cinit, cparam, cparams, csdecl, cstm, cstms :: QuasiQuoter citem, citems, ctyquals, cty, cunit :: QuasiQuoter cdecl = quasiquote exts typenames P.parseDecl cedecl = quasiquote exts typenames P.parseEdecl cenum = quasiquote exts typenames P.parseEnum cexp = quasiquote exts typenames P.parseExp cfun = quasiquote exts typenames P.parseFunc cinit = quasiquote exts typenames P.parseInit cparam = quasiquote exts typenames P.parseParam cparams = quasiquote exts typenames P.parseParams csdecl = quasiquote exts typenames P.parseStructDecl cstm = quasiquote exts typenames P.parseStm cstms = quasiquote exts typenames P.parseStms citem = quasiquote exts typenames P.parseBlockItem citems = quasiquote exts typenames P.parseBlockItems ctyquals = quasiquote exts typenames P.parseTypeQuals cty = quasiquote exts typenames P.parseType cunit = quasiquote exts typenames P.parseUnit language-c-quote-0.13.0.2/Language/C/Quote/CUDA.hs0000644000000000000000000000533007346545000017335 0ustar0000000000000000-- | -- Module : Language.C.Quote.CUDA -- Copyright : (c) 2006-2011 Harvard University -- (c) 2011-2013 Geoffrey Mainland -- : (c) 2013-2015 Drexel University -- License : BSD-style -- Maintainer : mainland@drexel.edu -- The quasiquoters exposed by this module support the CUDA extensions, including CUDA-specific declaration specifiers and @\<\<\<…>>>@ kernel invocation syntax. -- -- It includees partial support for C++11 lambda expressions syntax. -- -- Support for lambda-expressions has the following limitations: -- -- * the capture list must either be empty or have only the default capture mode specifier; -- -- * the return type cannot be explicitly specified; -- -- * the package supports C language, not C++, therefore lambda parameter list and body must be in valid C syntax. -- -- Examples of lambdas supported by the 'cexp' quasiquoter: -- -- > [] (int i) mutable {} -- -- > [&] { return 7; } -- module Language.C.Quote.CUDA ( ToIdent(..), ToConst(..), ToExp(..), cexp, cedecl, cdecl, csdecl, cenum, ctyquals, cty, cparam, cparams, cinit, cstm, cstms, citem, citems, cunit, cfun ) where import qualified Language.C.Parser as P import qualified Language.C.Syntax as C import Language.C.Quote.Base (ToIdent(..), ToConst(..), ToExp(..), quasiquote) import Language.Haskell.TH.Quote (QuasiQuoter) exts :: [C.Extensions] exts = [C.CUDA] typenames :: [String] typenames = concatMap (typeN 4) ["char", "uchar", "short", "ushort", "int", "uint", "long", "ulong", "longlong", "ulonglong", "float", "double"] ++ ["dim3"] typeN :: Int -> String -> [String] typeN k typename = [typename ++ show n | n <- [1..k]] cdecl, cedecl, cenum, cexp, cfun, cinit, cparam, cparams, csdecl, cstm, cstms :: QuasiQuoter citem, citems, ctyquals, cty, cunit :: QuasiQuoter cdecl = quasiquote exts typenames P.parseDecl cedecl = quasiquote exts typenames P.parseEdecl cenum = quasiquote exts typenames P.parseEnum cexp = quasiquote exts typenames P.parseExp cfun = quasiquote exts typenames P.parseFunc cinit = quasiquote exts typenames P.parseInit cparam = quasiquote exts typenames P.parseParam cparams = quasiquote exts typenames P.parseParams csdecl = quasiquote exts typenames P.parseStructDecl cstm = quasiquote exts typenames P.parseStm cstms = quasiquote exts typenames P.parseStms citem = quasiquote exts typenames P.parseBlockItem citems = quasiquote exts typenames P.parseBlockItems ctyquals = quasiquote exts typenames P.parseTypeQuals cty = quasiquote exts typenames P.parseType cunit = quasiquote exts typenames P.parseUnit language-c-quote-0.13.0.2/Language/C/Quote/GCC.hs0000644000000000000000000000345007346545000017216 0ustar0000000000000000-- | -- Module : Language.C.Quote.C -- Copyright : (c) 2006-2011 Harvard University -- (c) 2011-2013 Geoffrey Mainland -- : (c) 2013-2015 Drexel University -- License : BSD-style -- Maintainer : mainland@drexel.edu module Language.C.Quote.GCC ( ToIdent(..), ToConst(..), ToExp(..), cexp, cedecl, cdecl, csdecl, cenum, ctyquals, cty, cparam, cparams, cinit, cstm, cstms, citem, citems, cunit, cfun, cattr ) where import qualified Language.C.Parser as P import qualified Language.C.Syntax as C import Language.C.Quote.Base (ToIdent(..), ToConst(..), ToExp(..), quasiquote) import Language.Haskell.TH.Quote (QuasiQuoter) exts :: [C.Extensions] exts = [C.Gcc] typenames :: [String] typenames = [] cdecl, cedecl, cenum, cexp, cfun, cinit, cparam, cparams, csdecl, cstm, cstms :: QuasiQuoter citem, citems, ctyquals, cty, cunit, cattr :: QuasiQuoter cdecl = quasiquote exts typenames P.parseDecl cedecl = quasiquote exts typenames P.parseEdecl cenum = quasiquote exts typenames P.parseEnum cexp = quasiquote exts typenames P.parseExp cfun = quasiquote exts typenames P.parseFunc cinit = quasiquote exts typenames P.parseInit cparam = quasiquote exts typenames P.parseParam cparams = quasiquote exts typenames P.parseParams csdecl = quasiquote exts typenames P.parseStructDecl cstm = quasiquote exts typenames P.parseStm cstms = quasiquote exts typenames P.parseStms citem = quasiquote exts typenames P.parseBlockItem citems = quasiquote exts typenames P.parseBlockItems ctyquals = quasiquote exts typenames P.parseTypeQuals cty = quasiquote exts typenames P.parseType cunit = quasiquote exts typenames P.parseUnit cattr = quasiquote exts typenames P.parseAttr language-c-quote-0.13.0.2/Language/C/Quote/ObjC.hs0000644000000000000000000000662007346545000017441 0ustar0000000000000000-- | -- Module : Language.C.Quote.ObjC -- Copyright : (c) 2006-2011 Harvard University -- (c) 2011-2013 Geoffrey Mainland -- (c) 2013-2014 Manuel M T Chakravarty -- : (c) 2013-2015 Drexel University -- License : BSD-style -- Maintainer : mainland@drexel.edu {-# LANGUAGE FlexibleInstances #-} module Language.C.Quote.ObjC ( ToIdent(..), ToConst(..), ToExp(..), objcLit, cexp, cedecl, cdecl, csdecl, cenum, ctyquals, cty, cparam, cparams, cinit, cstm, cstms, citem, citems, cunit, cfun, objcprop, objcifdecls, objcimdecls, objcdictelem, objcpropattr, objcmethparam, objcmethproto, objcmethdef, objcmethrecv, objcarg ) where import qualified Language.C.Parser as P import qualified Language.C.Syntax as C import Language.C.Quote.Base (ToIdent(..), ToConst(..), ToExp(..), quasiquote) import Language.Haskell.TH.Quote (QuasiQuoter) exts :: [C.Extensions] exts = [C.ObjC, C.Blocks, C.Gcc] typenames :: [String] typenames = ["id", "instancetype"] -- | A wrapper for a value indicating that it should be treated as an -- Objective-C literal. newtype ObjCLit a = ObjCLit a deriving (Show, Read, Eq, Ord) instance ToExp (ObjCLit String) where toExp (ObjCLit s) loc = C.ObjCLitString [C.StringConst [show s] s loc] loc instance ToExp (ObjCLit Bool) where toExp (ObjCLit b) loc = C.ObjCLitBool b loc instance ToExp (ObjCLit Char) where toExp (ObjCLit c) loc = C.ObjCLitConst Nothing (C.CharConst (show c) c loc) loc -- | Indicates that a value should be treated as an Objective-C literal. objcLit :: a -> ObjCLit a objcLit = ObjCLit cdecl, cedecl, cenum, cexp, cfun, cinit, cparam, cparams, csdecl, cstm, cstms :: QuasiQuoter citem, citems, ctyquals, cty, cunit :: QuasiQuoter cdecl = quasiquote exts typenames P.parseDecl cedecl = quasiquote exts typenames P.parseEdecl cenum = quasiquote exts typenames P.parseEnum cexp = quasiquote exts typenames P.parseExp cfun = quasiquote exts typenames P.parseFunc cinit = quasiquote exts typenames P.parseInit cparam = quasiquote exts typenames P.parseParam cparams = quasiquote exts typenames P.parseParams csdecl = quasiquote exts typenames P.parseStructDecl cstm = quasiquote exts typenames P.parseStm cstms = quasiquote exts typenames P.parseStms citem = quasiquote exts typenames P.parseBlockItem citems = quasiquote exts typenames P.parseBlockItems ctyquals = quasiquote exts typenames P.parseTypeQuals cty = quasiquote exts typenames P.parseType cunit = quasiquote exts typenames P.parseUnit objcprop, objcpropattr, objcifdecls, objcimdecls, objcdictelem, objcmethparam, objcmethproto :: QuasiQuoter objcmethdef, objcmethrecv, objcarg :: QuasiQuoter objcprop = quasiquote exts typenames P.parseObjCProp objcifdecls = quasiquote exts typenames P.parseObjCIfaceDecls objcimdecls = quasiquote exts typenames P.parseObjCImplDecls objcpropattr = quasiquote exts typenames P.parseObjCPropAttr objcdictelem = quasiquote exts typenames P.parseObjCDictElem objcmethparam = quasiquote exts typenames P.parseObjCMethodParam objcmethproto = quasiquote exts typenames P.parseObjCMethodProto objcmethdef = quasiquote exts typenames P.parseObjCMethodDef objcmethrecv = quasiquote exts typenames P.parseObjCMethodRecv objcarg = quasiquote exts typenames P.parseObjCKeywordArg language-c-quote-0.13.0.2/Language/C/Quote/OpenCL.hs0000644000000000000000000000450707346545000017746 0ustar0000000000000000-- | -- Module : Language.C.Quote.OpenCL -- Copyright : (c) 2006-2011 Harvard University -- (c) 2011-2013 Geoffrey Mainland -- : (c) 2013-2015 Drexel University -- License : BSD-style -- Maintainer : mainland@drexel.edu module Language.C.Quote.OpenCL ( ToIdent(..), ToConst(..), ToExp(..), cexp, cedecl, cdecl, csdecl, cenum, ctyquals, cty, cparam, cparams, cinit, cstm, cstms, citem, citems, cunit, cfun ) where import qualified Language.C.Parser as P import qualified Language.C.Syntax as C import Language.C.Quote.Base (ToIdent(..), ToConst(..), ToExp(..), quasiquote) import Language.Haskell.TH.Quote (QuasiQuoter) exts :: [C.Extensions] exts = [C.OpenCL] typenames :: [String] typenames = ["bool", "char", "uchar", "short", "ushort", "int", "uint", "long" , "ulong", "float", "half"] ++ ["size_t", "ptrdiff_t", "intptr_t", "uintpyt_t", "void"] ++ concatMap typeN ["char", "uchar", "short", "ushort", "int", "uint", "long", "ulong", "float"] ++ ["image2d_t", "image3d_t", "sampler_t", "event_t"] -- OpenCL 1.2 ++ ["double"] ++ concatMap typeN ["double"] ++ ["image2d_array_t", "image1d_t", "image1d_buffer_t", "image1d_array_t"] typeN :: String -> [String] typeN typename = [typename ++ show n | n <- [2, 3, 4, 8, 16 :: Integer]] cdecl, cedecl, cenum, cexp, cfun, cinit, cparam, cparams, csdecl, cstm, cstms :: QuasiQuoter citem, citems, ctyquals, cty, cunit :: QuasiQuoter cdecl = quasiquote exts typenames P.parseDecl cedecl = quasiquote exts typenames P.parseEdecl cenum = quasiquote exts typenames P.parseEnum cexp = quasiquote exts typenames P.parseExp cfun = quasiquote exts typenames P.parseFunc cinit = quasiquote exts typenames P.parseInit cparam = quasiquote exts typenames P.parseParam cparams = quasiquote exts typenames P.parseParams csdecl = quasiquote exts typenames P.parseStructDecl cstm = quasiquote exts typenames P.parseStm cstms = quasiquote exts typenames P.parseStms citem = quasiquote exts typenames P.parseBlockItem citems = quasiquote exts typenames P.parseBlockItems ctyquals = quasiquote exts typenames P.parseTypeQuals cty = quasiquote exts typenames P.parseType cunit = quasiquote exts typenames P.parseUnit language-c-quote-0.13.0.2/Language/C/Smart.hs0000644000000000000000000000554407346545000016621 0ustar0000000000000000-- | -- Module : Language.C.Smart -- Copyright : (c) 2010-2011 Harvard University -- (c) 2011-2013 Geoffrey Mainland -- License : BSD-style -- Maintainer : mainland@drexel.edu {-# LANGUAGE CPP #-} {-# LANGUAGE QuasiQuotes #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module Language.C.Smart where import Language.C.Quote.C import Language.C.Syntax as C #if !MIN_VERSION_template_haskell(2,7,0) import qualified Data.Loc import qualified Language.C.Syntax #endif /* !MIN_VERSION_template_haskell(2,7,0) */ instance Enum Exp where toEnum n = [cexp|$int:n|] fromEnum [cexp|$int:n|] = fromIntegral n fromEnum [cexp|$uint:n|] = fromIntegral n fromEnum [cexp|$lint:n|] = fromIntegral n fromEnum [cexp|$ulint:n|] = fromIntegral n fromEnum _ = error "fromEnum: non-integer constant C expressions" instance Num C.Exp where e1 + e2 = [cexp|$exp:e1 + $exp:e2|] e1 * e2 = [cexp|$exp:e1 * $exp:e2|] e1 - e2 = [cexp|$exp:e1 - $exp:e2|] negate e = [cexp|-$exp:e|] abs e = [cexp|abs($exp:e)|] signum e = [cexp|$exp:e > 0 ? 1 : ($exp:e < 0 ? -1 : 0)|] fromInteger n = [cexp|$int:n|] instance Real C.Exp where toRational [cexp|$float:n|] = toRational n toRational [cexp|$double:n|] = toRational n toRational [cexp|$ldouble:n|] = toRational n toRational _ = error "fromEnum: non-rational constant C expressions" instance Integral C.Exp where e1 `quotRem` e2 = ([cexp|$exp:e1 / $exp:e2|], [cexp|$exp:e1 % $exp:e2|]) toInteger [cexp|$int:n|] = n toInteger [cexp|$uint:n|] = n toInteger [cexp|$lint:n|] = n toInteger [cexp|$ulint:n|] = n toInteger _ = error "fromInteger: non-integer constant C expressions" instance Fractional C.Exp where e1 / e2 = [cexp|$exp:e1 / $exp:e2|] recip e = [cexp|1 / $exp:e|] fromRational n = [cexp|$double:(fromRational n)|] instance Floating C.Exp where pi = [cexp|3.141592653589793238|] exp e = [cexp|exp($exp:e)|] sqrt e = [cexp|sqrt($exp:e)|] log e = [cexp|log($exp:e)|] e1 ** e2 = [cexp|pow($exp:e1, $exp:e2)|] logBase e1 e2 = [cexp|log($exp:e2)/log($exp:e1)|] sin e = [cexp|sin($exp:e)|] tan e = [cexp|tan($exp:e)|] cos e = [cexp|cos($exp:e)|] asin e = [cexp|asin($exp:e)|] atan e = [cexp|atan($exp:e)|] acos e = [cexp|acos($exp:e)|] sinh e = [cexp|sinh($exp:e)|] tanh e = [cexp|tanh($exp:e)|] cosh e = [cexp|cosh($exp:e)|] asinh e = [cexp|asinh($exp:e)|] atanh e = [cexp|atanh($exp:e)|] acosh e = [cexp|acosh($exp:e)|] infix 4 === (===) :: C.Exp -> C.Exp -> C.Stm e1 === e2 = [cstm|$exp:e1 = $exp:e2;|] infix 4 += (+=) :: C.Exp -> C.Exp -> C.Stm e1 += e2 = [cstm|$exp:e1 += $exp:e2;|] language-c-quote-0.13.0.2/Language/C/Syntax-instances.hs0000644000000000000000000006637607346545000021020 0ustar0000000000000000instance Located Id where locOf (Id _ l) = locOf l locOf (AntiId _ l) = locOf l instance Located StringLit where locOf (StringLit _ _ l) = locOf l instance Located Storage where locOf (Tauto l) = locOf l locOf (Tregister l) = locOf l locOf (Tstatic l) = locOf l locOf (Textern _ l) = locOf l locOf (Ttypedef l) = locOf l locOf (T__block l) = locOf l locOf (TObjC__weak l) = locOf l locOf (TObjC__strong l) = locOf l locOf (TObjC__unsafe_unretained l) = locOf l instance Located TypeQual where locOf (Tconst l) = locOf l locOf (Tvolatile l) = locOf l locOf (EscTypeQual _ l) = locOf l locOf (AntiTypeQual _ l) = locOf l locOf (AntiTypeQuals _ l) = locOf l locOf (Tinline l) = locOf l locOf (Trestrict l) = locOf l locOf (T__restrict l) = locOf l locOf (TAttr _) = noLoc locOf (TCUDAdevice l) = locOf l locOf (TCUDAglobal l) = locOf l locOf (TCUDAhost l) = locOf l locOf (TCUDAconstant l) = locOf l locOf (TCUDAshared l) = locOf l locOf (TCUDArestrict l) = locOf l locOf (TCUDAnoinline l) = locOf l locOf (TCLprivate l) = locOf l locOf (TCLlocal l) = locOf l locOf (TCLglobal l) = locOf l locOf (TCLconstant l) = locOf l locOf (TCLreadonly l) = locOf l locOf (TCLwriteonly l) = locOf l locOf (TCLkernel l) = locOf l instance Located Sign where locOf (Tsigned l) = locOf l locOf (Tunsigned l) = locOf l instance Located TypeSpec where locOf (Tvoid l) = locOf l locOf (Tchar _ l) = locOf l locOf (Tshort _ l) = locOf l locOf (Tint _ l) = locOf l locOf (Tlong _ l) = locOf l locOf (Tlong_long _ l) = locOf l locOf (Tfloat l) = locOf l locOf (Tdouble l) = locOf l locOf (Tlong_double l) = locOf l locOf (Tstruct _ _ _ l) = locOf l locOf (Tunion _ _ _ l) = locOf l locOf (Tenum _ _ _ l) = locOf l locOf (Tnamed _ _ l) = locOf l locOf (T_Bool l) = locOf l locOf (Tfloat_Complex l) = locOf l locOf (Tdouble_Complex l) = locOf l locOf (Tlong_double_Complex l) = locOf l locOf (Tfloat_Imaginary l) = locOf l locOf (Tdouble_Imaginary l) = locOf l locOf (Tlong_double_Imaginary l) = locOf l locOf (TtypeofExp _ l) = locOf l locOf (TtypeofType _ l) = locOf l locOf (Tva_list l) = locOf l instance Located DeclSpec where locOf (DeclSpec _ _ _ l) = locOf l locOf (AntiDeclSpec _ l) = locOf l locOf (AntiTypeDeclSpec _ _ _ l) = locOf l instance Located ArraySize where locOf (ArraySize _ _ l) = locOf l locOf (VariableArraySize l) = locOf l locOf (NoArraySize l) = locOf l instance Located Decl where locOf (DeclRoot l) = locOf l locOf (Ptr _ _ l) = locOf l locOf (Array _ _ _ l) = locOf l locOf (Proto _ _ l) = locOf l locOf (OldProto _ _ l) = locOf l locOf (AntiTypeDecl _ l) = locOf l locOf (BlockPtr _ _ l) = locOf l instance Located Type where locOf (Type _ _ l) = locOf l locOf (AntiType _ l) = locOf l instance Located Designator where locOf (IndexDesignator _ l) = locOf l locOf (MemberDesignator _ l) = locOf l instance Located Designation where locOf (Designation _ l) = locOf l instance Located Initializer where locOf (ExpInitializer _ l) = locOf l locOf (CompoundInitializer _ l) = locOf l locOf (AntiInit _ l) = locOf l locOf (AntiInits _ l) = locOf l instance Located Init where locOf (Init _ _ _ _ _ l) = locOf l instance Located Typedef where locOf (Typedef _ _ _ l) = locOf l instance Located InitGroup where locOf (InitGroup _ _ _ l) = locOf l locOf (TypedefGroup _ _ _ l) = locOf l locOf (AntiDecl _ l) = locOf l locOf (AntiDecls _ l) = locOf l instance Located Field where locOf (Field _ _ _ l) = locOf l instance Located FieldGroup where locOf (FieldGroup _ _ l) = locOf l locOf (AntiSdecl _ l) = locOf l locOf (AntiSdecls _ l) = locOf l instance Located CEnum where locOf (CEnum _ _ l) = locOf l locOf (AntiEnum _ l) = locOf l locOf (AntiEnums _ l) = locOf l instance Located Attr where locOf (Attr _ _ l) = locOf l locOf (AntiAttr _ l) = locOf l locOf (AntiAttrs _ l) = locOf l instance Located Param where locOf (Param _ _ _ l) = locOf l locOf (AntiParam _ l) = locOf l locOf (AntiParams _ l) = locOf l instance Located Params where locOf (Params _ _ l) = locOf l instance Located Func where locOf (Func _ _ _ _ _ l) = locOf l locOf (OldFunc _ _ _ _ _ _ l) = locOf l instance Located Definition where locOf (FuncDef _ l) = locOf l locOf (DecDef _ l) = locOf l locOf (EscDef _ l) = locOf l locOf (AntiFunc _ l) = locOf l locOf (AntiEsc _ l) = locOf l locOf (AntiEdecl _ l) = locOf l locOf (AntiEdecls _ l) = locOf l locOf (ObjCClassDec _ l) = locOf l locOf (ObjCClassIface _ _ _ _ _ _ l) = locOf l locOf (ObjCCatIface _ _ _ _ _ l) = locOf l locOf (ObjCProtDec _ l) = locOf l locOf (ObjCProtDef _ _ _ l) = locOf l locOf (ObjCClassImpl _ _ _ _ l) = locOf l locOf (ObjCCatImpl _ _ _ l) = locOf l locOf (ObjCSynDef _ l) = locOf l locOf (ObjCDynDef _ l) = locOf l locOf (ObjCMethDef _ _ l) = locOf l locOf (ObjCCompAlias _ _ l) = locOf l locOf (AntiObjCMeth _ l) = locOf l locOf (AntiObjCMeths _ l) = locOf l instance Located Stm where locOf (Label _ _ _ l) = locOf l locOf (Case _ _ l) = locOf l locOf (CaseRange _ _ _ l) = locOf l locOf (Default _ l) = locOf l locOf (Exp _ l) = locOf l locOf (Block _ l) = locOf l locOf (If _ _ _ l) = locOf l locOf (Switch _ _ l) = locOf l locOf (While _ _ l) = locOf l locOf (DoWhile _ _ l) = locOf l locOf (For _ _ _ _ l) = locOf l locOf (Goto _ l) = locOf l locOf (Continue l) = locOf l locOf (Break l) = locOf l locOf (Return _ l) = locOf l locOf (Pragma _ l) = locOf l locOf (Comment _ _ l) = locOf l locOf (EscStm _ l) = locOf l locOf (AntiEscStm _ l) = locOf l locOf (AntiPragma _ l) = locOf l locOf (AntiComment _ _ l) = locOf l locOf (AntiStm _ l) = locOf l locOf (AntiStms _ l) = locOf l locOf (Asm _ _ _ _ _ _ l) = locOf l locOf (AsmGoto _ _ _ _ _ _ l) = locOf l locOf (ObjCTry _ _ _ l) = locOf l locOf (ObjCThrow _ l) = locOf l locOf (ObjCSynchronized _ _ l) = locOf l locOf (ObjCAutoreleasepool _ l) = locOf l instance Located BlockItem where locOf (BlockDecl _) = noLoc locOf (BlockStm _) = noLoc locOf (AntiBlockItem _ l) = locOf l locOf (AntiBlockItems _ l) = locOf l instance Located Const where locOf (IntConst _ _ _ l) = locOf l locOf (LongIntConst _ _ _ l) = locOf l locOf (LongLongIntConst _ _ _ l) = locOf l locOf (FloatConst _ _ l) = locOf l locOf (DoubleConst _ _ l) = locOf l locOf (LongDoubleConst _ _ l) = locOf l locOf (CharConst _ _ l) = locOf l locOf (StringConst _ _ l) = locOf l locOf (AntiConst _ l) = locOf l locOf (AntiInt _ l) = locOf l locOf (AntiUInt _ l) = locOf l locOf (AntiLInt _ l) = locOf l locOf (AntiULInt _ l) = locOf l locOf (AntiLLInt _ l) = locOf l locOf (AntiULLInt _ l) = locOf l locOf (AntiFloat _ l) = locOf l locOf (AntiDouble _ l) = locOf l locOf (AntiLongDouble _ l) = locOf l locOf (AntiChar _ l) = locOf l locOf (AntiString _ l) = locOf l instance Located Exp where locOf (Var _ l) = locOf l locOf (Const _ l) = locOf l locOf (BinOp _ _ _ l) = locOf l locOf (Assign _ _ _ l) = locOf l locOf (PreInc _ l) = locOf l locOf (PostInc _ l) = locOf l locOf (PreDec _ l) = locOf l locOf (PostDec _ l) = locOf l locOf (UnOp _ _ l) = locOf l locOf (SizeofExp _ l) = locOf l locOf (SizeofType _ l) = locOf l locOf (Cast _ _ l) = locOf l locOf (Cond _ _ _ l) = locOf l locOf (Member _ _ l) = locOf l locOf (PtrMember _ _ l) = locOf l locOf (Index _ _ l) = locOf l locOf (FnCall _ _ l) = locOf l locOf (CudaCall _ _ _ l) = locOf l locOf (Seq _ _ l) = locOf l locOf (CompoundLit _ _ l) = locOf l locOf (StmExpr _ l) = locOf l locOf (EscExp _ l) = locOf l locOf (AntiEscExp _ l) = locOf l locOf (AntiExp _ l) = locOf l locOf (AntiArgs _ l) = locOf l locOf (BuiltinVaArg _ _ l) = locOf l locOf (BlockLit _ _ _ l) = locOf l locOf (ObjCMsg _ _ _ l) = locOf l locOf (ObjCLitConst _ _ l) = locOf l locOf (ObjCLitString _ l) = locOf l locOf (ObjCLitBool _ l) = locOf l locOf (ObjCLitArray _ l) = locOf l locOf (ObjCLitDict _ l) = locOf l locOf (ObjCLitBoxed _ l) = locOf l locOf (ObjCEncode _ l) = locOf l locOf (ObjCProtocol _ l) = locOf l locOf (ObjCSelector _ l) = locOf l locOf (Lambda _ _ _ l) = locOf l instance Located LambdaIntroducer where locOf (LambdaIntroducer _ l) = locOf l instance Located LambdaDeclarator where locOf (LambdaDeclarator _ _ _ l) = locOf l instance Located BlockType where locOf (BlockVoid l) = locOf l locOf (BlockParam _ l) = locOf l locOf (BlockType _ l) = locOf l instance Located ExeConfig where locOf (ExeConfig _ _ _ _ l) = locOf l instance Located ObjCIvarDecl where locOf (ObjCIvarVisi _ l) = locOf l locOf (ObjCIvarDecl _ l) = locOf l instance Located ObjCVisibilitySpec where locOf (ObjCPrivate l) = locOf l locOf (ObjCPublic l) = locOf l locOf (ObjCProtected l) = locOf l locOf (ObjCPackage l) = locOf l instance Located ObjCIfaceDecl where locOf (ObjCIfaceProp _ _ l) = locOf l locOf (ObjCIfaceReq _ l) = locOf l locOf (ObjCIfaceMeth _ l) = locOf l locOf (ObjCIfaceDecl _ l) = locOf l locOf (AntiObjCProp _ l) = locOf l locOf (AntiObjCProps _ l) = locOf l locOf (AntiObjCIfaceDecl _ l) = locOf l locOf (AntiObjCIfaceDecls _ l) = locOf l instance Located ObjCPropAttr where locOf (ObjCGetter _ l) = locOf l locOf (ObjCSetter _ l) = locOf l locOf (ObjCReadonly l) = locOf l locOf (ObjCReadwrite l) = locOf l locOf (ObjCAssign l) = locOf l locOf (ObjCRetain l) = locOf l locOf (ObjCCopy l) = locOf l locOf (ObjCNonatomic l) = locOf l locOf (ObjCAtomic l) = locOf l locOf (ObjCStrong l) = locOf l locOf (ObjCWeak l) = locOf l locOf (ObjCUnsafeUnretained l) = locOf l locOf (AntiObjCAttr _ l) = locOf l locOf (AntiObjCAttrs _ l) = locOf l instance Located ObjCMethodReq where locOf (ObjCRequired l) = locOf l locOf (ObjCOptional l) = locOf l instance Located ObjCParam where locOf (ObjCParam _ _ _ _ l) = locOf l locOf (AntiObjCParam _ l) = locOf l locOf (AntiObjCParams _ l) = locOf l instance Located ObjCMethodProto where locOf (ObjCMethodProto _ _ _ _ _ _ l) = locOf l locOf (AntiObjCMethodProto _ l) = locOf l instance Located ObjCCatch where locOf (ObjCCatch _ _ l) = locOf l instance Located ObjCRecv where locOf (ObjCRecvSuper l) = locOf l locOf (ObjCRecvExp _ l) = locOf l locOf (AntiObjCRecv _ l) = locOf l instance Located ObjCArg where locOf (ObjCArg _ _ l) = locOf l locOf (AntiObjCArg _ l) = locOf l locOf (AntiObjCArgs _ l) = locOf l instance Located ObjCDictElem where locOf (ObjCDictElem _ _ l) = locOf l locOf (AntiObjCDictElems _ l) = locOf l instance Relocatable Id where reloc l (Id x0 _) = (Id x0 (fromLoc l)) reloc l (AntiId x0 _) = (AntiId x0 (fromLoc l)) instance Relocatable StringLit where reloc l (StringLit x0 x1 _) = (StringLit x0 x1 (fromLoc l)) instance Relocatable Storage where reloc l (Tauto _) = (Tauto (fromLoc l)) reloc l (Tregister _) = (Tregister (fromLoc l)) reloc l (Tstatic _) = (Tstatic (fromLoc l)) reloc l (Textern x0 _) = (Textern x0 (fromLoc l)) reloc l (Ttypedef _) = (Ttypedef (fromLoc l)) reloc l (T__block _) = (T__block (fromLoc l)) reloc l (TObjC__weak _) = (TObjC__weak (fromLoc l)) reloc l (TObjC__strong _) = (TObjC__strong (fromLoc l)) reloc l (TObjC__unsafe_unretained _) = (TObjC__unsafe_unretained (fromLoc l)) instance Relocatable TypeQual where reloc l (Tconst _) = (Tconst (fromLoc l)) reloc l (Tvolatile _) = (Tvolatile (fromLoc l)) reloc l (EscTypeQual x0 _) = (EscTypeQual x0 (fromLoc l)) reloc l (AntiTypeQual x0 _) = (AntiTypeQual x0 (fromLoc l)) reloc l (AntiTypeQuals x0 _) = (AntiTypeQuals x0 (fromLoc l)) reloc l (Tinline _) = (Tinline (fromLoc l)) reloc l (Trestrict _) = (Trestrict (fromLoc l)) reloc l (T__restrict _) = (T__restrict (fromLoc l)) reloc _ (TAttr x0) = (TAttr x0) reloc l (TCUDAdevice _) = (TCUDAdevice (fromLoc l)) reloc l (TCUDAglobal _) = (TCUDAglobal (fromLoc l)) reloc l (TCUDAhost _) = (TCUDAhost (fromLoc l)) reloc l (TCUDAconstant _) = (TCUDAconstant (fromLoc l)) reloc l (TCUDAshared _) = (TCUDAshared (fromLoc l)) reloc l (TCUDArestrict _) = (TCUDArestrict (fromLoc l)) reloc l (TCUDAnoinline _) = (TCUDAnoinline (fromLoc l)) reloc l (TCLprivate _) = (TCLprivate (fromLoc l)) reloc l (TCLlocal _) = (TCLlocal (fromLoc l)) reloc l (TCLglobal _) = (TCLglobal (fromLoc l)) reloc l (TCLconstant _) = (TCLconstant (fromLoc l)) reloc l (TCLreadonly _) = (TCLreadonly (fromLoc l)) reloc l (TCLwriteonly _) = (TCLwriteonly (fromLoc l)) reloc l (TCLkernel _) = (TCLkernel (fromLoc l)) instance Relocatable Sign where reloc l (Tsigned _) = (Tsigned (fromLoc l)) reloc l (Tunsigned _) = (Tunsigned (fromLoc l)) instance Relocatable TypeSpec where reloc l (Tvoid _) = (Tvoid (fromLoc l)) reloc l (Tchar x0 _) = (Tchar x0 (fromLoc l)) reloc l (Tshort x0 _) = (Tshort x0 (fromLoc l)) reloc l (Tint x0 _) = (Tint x0 (fromLoc l)) reloc l (Tlong x0 _) = (Tlong x0 (fromLoc l)) reloc l (Tlong_long x0 _) = (Tlong_long x0 (fromLoc l)) reloc l (Tfloat _) = (Tfloat (fromLoc l)) reloc l (Tdouble _) = (Tdouble (fromLoc l)) reloc l (Tlong_double _) = (Tlong_double (fromLoc l)) reloc l (Tstruct x0 x1 x2 _) = (Tstruct x0 x1 x2 (fromLoc l)) reloc l (Tunion x0 x1 x2 _) = (Tunion x0 x1 x2 (fromLoc l)) reloc l (Tenum x0 x1 x2 _) = (Tenum x0 x1 x2 (fromLoc l)) reloc l (Tnamed x0 x1 _) = (Tnamed x0 x1 (fromLoc l)) reloc l (T_Bool _) = (T_Bool (fromLoc l)) reloc l (Tfloat_Complex _) = (Tfloat_Complex (fromLoc l)) reloc l (Tdouble_Complex _) = (Tdouble_Complex (fromLoc l)) reloc l (Tlong_double_Complex _) = (Tlong_double_Complex (fromLoc l)) reloc l (Tfloat_Imaginary _) = (Tfloat_Imaginary (fromLoc l)) reloc l (Tdouble_Imaginary _) = (Tdouble_Imaginary (fromLoc l)) reloc l (Tlong_double_Imaginary _) = (Tlong_double_Imaginary (fromLoc l)) reloc l (TtypeofExp x0 _) = (TtypeofExp x0 (fromLoc l)) reloc l (TtypeofType x0 _) = (TtypeofType x0 (fromLoc l)) reloc l (Tva_list _) = (Tva_list (fromLoc l)) instance Relocatable DeclSpec where reloc l (DeclSpec x0 x1 x2 _) = (DeclSpec x0 x1 x2 (fromLoc l)) reloc l (AntiDeclSpec x0 _) = (AntiDeclSpec x0 (fromLoc l)) reloc l (AntiTypeDeclSpec x0 x1 x2 _) = (AntiTypeDeclSpec x0 x1 x2 (fromLoc l)) instance Relocatable ArraySize where reloc l (ArraySize x0 x1 _) = (ArraySize x0 x1 (fromLoc l)) reloc l (VariableArraySize _) = (VariableArraySize (fromLoc l)) reloc l (NoArraySize _) = (NoArraySize (fromLoc l)) instance Relocatable Decl where reloc l (DeclRoot _) = (DeclRoot (fromLoc l)) reloc l (Ptr x0 x1 _) = (Ptr x0 x1 (fromLoc l)) reloc l (Array x0 x1 x2 _) = (Array x0 x1 x2 (fromLoc l)) reloc l (Proto x0 x1 _) = (Proto x0 x1 (fromLoc l)) reloc l (OldProto x0 x1 _) = (OldProto x0 x1 (fromLoc l)) reloc l (AntiTypeDecl x0 _) = (AntiTypeDecl x0 (fromLoc l)) reloc l (BlockPtr x0 x1 _) = (BlockPtr x0 x1 (fromLoc l)) instance Relocatable Type where reloc l (Type x0 x1 _) = (Type x0 x1 (fromLoc l)) reloc l (AntiType x0 _) = (AntiType x0 (fromLoc l)) instance Relocatable Designator where reloc l (IndexDesignator x0 _) = (IndexDesignator x0 (fromLoc l)) reloc l (MemberDesignator x0 _) = (MemberDesignator x0 (fromLoc l)) instance Relocatable Designation where reloc l (Designation x0 _) = (Designation x0 (fromLoc l)) instance Relocatable Initializer where reloc l (ExpInitializer x0 _) = (ExpInitializer x0 (fromLoc l)) reloc l (CompoundInitializer x0 _) = (CompoundInitializer x0 (fromLoc l)) reloc l (AntiInit x0 _) = (AntiInit x0 (fromLoc l)) reloc l (AntiInits x0 _) = (AntiInits x0 (fromLoc l)) instance Relocatable Init where reloc l (Init x0 x1 x2 x3 x4 _) = (Init x0 x1 x2 x3 x4 (fromLoc l)) instance Relocatable Typedef where reloc l (Typedef x0 x1 x2 _) = (Typedef x0 x1 x2 (fromLoc l)) instance Relocatable InitGroup where reloc l (InitGroup x0 x1 x2 _) = (InitGroup x0 x1 x2 (fromLoc l)) reloc l (TypedefGroup x0 x1 x2 _) = (TypedefGroup x0 x1 x2 (fromLoc l)) reloc l (AntiDecl x0 _) = (AntiDecl x0 (fromLoc l)) reloc l (AntiDecls x0 _) = (AntiDecls x0 (fromLoc l)) instance Relocatable Field where reloc l (Field x0 x1 x2 _) = (Field x0 x1 x2 (fromLoc l)) instance Relocatable FieldGroup where reloc l (FieldGroup x0 x1 _) = (FieldGroup x0 x1 (fromLoc l)) reloc l (AntiSdecl x0 _) = (AntiSdecl x0 (fromLoc l)) reloc l (AntiSdecls x0 _) = (AntiSdecls x0 (fromLoc l)) instance Relocatable CEnum where reloc l (CEnum x0 x1 _) = (CEnum x0 x1 (fromLoc l)) reloc l (AntiEnum x0 _) = (AntiEnum x0 (fromLoc l)) reloc l (AntiEnums x0 _) = (AntiEnums x0 (fromLoc l)) instance Relocatable Attr where reloc l (Attr x0 x1 _) = (Attr x0 x1 (fromLoc l)) reloc l (AntiAttr x0 _) = (AntiAttr x0 (fromLoc l)) reloc l (AntiAttrs x0 _) = (AntiAttrs x0 (fromLoc l)) instance Relocatable Param where reloc l (Param x0 x1 x2 _) = (Param x0 x1 x2 (fromLoc l)) reloc l (AntiParam x0 _) = (AntiParam x0 (fromLoc l)) reloc l (AntiParams x0 _) = (AntiParams x0 (fromLoc l)) instance Relocatable Params where reloc l (Params x0 x1 _) = (Params x0 x1 (fromLoc l)) instance Relocatable Func where reloc l (Func x0 x1 x2 x3 x4 _) = (Func x0 x1 x2 x3 x4 (fromLoc l)) reloc l (OldFunc x0 x1 x2 x3 x4 x5 _) = (OldFunc x0 x1 x2 x3 x4 x5 (fromLoc l)) instance Relocatable Definition where reloc l (FuncDef x0 _) = (FuncDef x0 (fromLoc l)) reloc l (DecDef x0 _) = (DecDef x0 (fromLoc l)) reloc l (EscDef x0 _) = (EscDef x0 (fromLoc l)) reloc l (AntiFunc x0 _) = (AntiFunc x0 (fromLoc l)) reloc l (AntiEsc x0 _) = (AntiEsc x0 (fromLoc l)) reloc l (AntiEdecl x0 _) = (AntiEdecl x0 (fromLoc l)) reloc l (AntiEdecls x0 _) = (AntiEdecls x0 (fromLoc l)) reloc l (ObjCClassDec x0 _) = (ObjCClassDec x0 (fromLoc l)) reloc l (ObjCClassIface x0 x1 x2 x3 x4 x5 _) = (ObjCClassIface x0 x1 x2 x3 x4 x5 (fromLoc l)) reloc l (ObjCCatIface x0 x1 x2 x3 x4 _) = (ObjCCatIface x0 x1 x2 x3 x4 (fromLoc l)) reloc l (ObjCProtDec x0 _) = (ObjCProtDec x0 (fromLoc l)) reloc l (ObjCProtDef x0 x1 x2 _) = (ObjCProtDef x0 x1 x2 (fromLoc l)) reloc l (ObjCClassImpl x0 x1 x2 x3 _) = (ObjCClassImpl x0 x1 x2 x3 (fromLoc l)) reloc l (ObjCCatImpl x0 x1 x2 _) = (ObjCCatImpl x0 x1 x2 (fromLoc l)) reloc l (ObjCSynDef x0 _) = (ObjCSynDef x0 (fromLoc l)) reloc l (ObjCDynDef x0 _) = (ObjCDynDef x0 (fromLoc l)) reloc l (ObjCMethDef x0 x1 _) = (ObjCMethDef x0 x1 (fromLoc l)) reloc l (ObjCCompAlias x0 x1 _) = (ObjCCompAlias x0 x1 (fromLoc l)) reloc l (AntiObjCMeth x0 _) = (AntiObjCMeth x0 (fromLoc l)) reloc l (AntiObjCMeths x0 _) = (AntiObjCMeths x0 (fromLoc l)) instance Relocatable Stm where reloc l (Label x0 x1 x2 _) = (Label x0 x1 x2 (fromLoc l)) reloc l (Case x0 x1 _) = (Case x0 x1 (fromLoc l)) reloc l (CaseRange x0 x1 x2 _) = (CaseRange x0 x1 x2 (fromLoc l)) reloc l (Default x0 _) = (Default x0 (fromLoc l)) reloc l (Exp x0 _) = (Exp x0 (fromLoc l)) reloc l (Block x0 _) = (Block x0 (fromLoc l)) reloc l (If x0 x1 x2 _) = (If x0 x1 x2 (fromLoc l)) reloc l (Switch x0 x1 _) = (Switch x0 x1 (fromLoc l)) reloc l (While x0 x1 _) = (While x0 x1 (fromLoc l)) reloc l (DoWhile x0 x1 _) = (DoWhile x0 x1 (fromLoc l)) reloc l (For x0 x1 x2 x3 _) = (For x0 x1 x2 x3 (fromLoc l)) reloc l (Goto x0 _) = (Goto x0 (fromLoc l)) reloc l (Continue _) = (Continue (fromLoc l)) reloc l (Break _) = (Break (fromLoc l)) reloc l (Return x0 _) = (Return x0 (fromLoc l)) reloc l (Pragma x0 _) = (Pragma x0 (fromLoc l)) reloc l (Comment x0 x1 _) = (Comment x0 x1 (fromLoc l)) reloc l (EscStm x0 _) = (EscStm x0 (fromLoc l)) reloc l (AntiEscStm x0 _) = (AntiEscStm x0 (fromLoc l)) reloc l (AntiPragma x0 _) = (AntiPragma x0 (fromLoc l)) reloc l (AntiComment x0 x1 _) = (AntiComment x0 x1 (fromLoc l)) reloc l (AntiStm x0 _) = (AntiStm x0 (fromLoc l)) reloc l (AntiStms x0 _) = (AntiStms x0 (fromLoc l)) reloc l (Asm x0 x1 x2 x3 x4 x5 _) = (Asm x0 x1 x2 x3 x4 x5 (fromLoc l)) reloc l (AsmGoto x0 x1 x2 x3 x4 x5 _) = (AsmGoto x0 x1 x2 x3 x4 x5 (fromLoc l)) reloc l (ObjCTry x0 x1 x2 _) = (ObjCTry x0 x1 x2 (fromLoc l)) reloc l (ObjCThrow x0 _) = (ObjCThrow x0 (fromLoc l)) reloc l (ObjCSynchronized x0 x1 _) = (ObjCSynchronized x0 x1 (fromLoc l)) reloc l (ObjCAutoreleasepool x0 _) = (ObjCAutoreleasepool x0 (fromLoc l)) instance Relocatable BlockItem where reloc _ (BlockDecl x0) = (BlockDecl x0) reloc _ (BlockStm x0) = (BlockStm x0) reloc l (AntiBlockItem x0 _) = (AntiBlockItem x0 (fromLoc l)) reloc l (AntiBlockItems x0 _) = (AntiBlockItems x0 (fromLoc l)) instance Relocatable Const where reloc l (IntConst x0 x1 x2 _) = (IntConst x0 x1 x2 (fromLoc l)) reloc l (LongIntConst x0 x1 x2 _) = (LongIntConst x0 x1 x2 (fromLoc l)) reloc l (LongLongIntConst x0 x1 x2 _) = (LongLongIntConst x0 x1 x2 (fromLoc l)) reloc l (FloatConst x0 x1 _) = (FloatConst x0 x1 (fromLoc l)) reloc l (DoubleConst x0 x1 _) = (DoubleConst x0 x1 (fromLoc l)) reloc l (LongDoubleConst x0 x1 _) = (LongDoubleConst x0 x1 (fromLoc l)) reloc l (CharConst x0 x1 _) = (CharConst x0 x1 (fromLoc l)) reloc l (StringConst x0 x1 _) = (StringConst x0 x1 (fromLoc l)) reloc l (AntiConst x0 _) = (AntiConst x0 (fromLoc l)) reloc l (AntiInt x0 _) = (AntiInt x0 (fromLoc l)) reloc l (AntiUInt x0 _) = (AntiUInt x0 (fromLoc l)) reloc l (AntiLInt x0 _) = (AntiLInt x0 (fromLoc l)) reloc l (AntiULInt x0 _) = (AntiULInt x0 (fromLoc l)) reloc l (AntiLLInt x0 _) = (AntiLLInt x0 (fromLoc l)) reloc l (AntiULLInt x0 _) = (AntiULLInt x0 (fromLoc l)) reloc l (AntiFloat x0 _) = (AntiFloat x0 (fromLoc l)) reloc l (AntiDouble x0 _) = (AntiDouble x0 (fromLoc l)) reloc l (AntiLongDouble x0 _) = (AntiLongDouble x0 (fromLoc l)) reloc l (AntiChar x0 _) = (AntiChar x0 (fromLoc l)) reloc l (AntiString x0 _) = (AntiString x0 (fromLoc l)) instance Relocatable Exp where reloc l (Var x0 _) = (Var x0 (fromLoc l)) reloc l (Const x0 _) = (Const x0 (fromLoc l)) reloc l (BinOp x0 x1 x2 _) = (BinOp x0 x1 x2 (fromLoc l)) reloc l (Assign x0 x1 x2 _) = (Assign x0 x1 x2 (fromLoc l)) reloc l (PreInc x0 _) = (PreInc x0 (fromLoc l)) reloc l (PostInc x0 _) = (PostInc x0 (fromLoc l)) reloc l (PreDec x0 _) = (PreDec x0 (fromLoc l)) reloc l (PostDec x0 _) = (PostDec x0 (fromLoc l)) reloc l (UnOp x0 x1 _) = (UnOp x0 x1 (fromLoc l)) reloc l (SizeofExp x0 _) = (SizeofExp x0 (fromLoc l)) reloc l (SizeofType x0 _) = (SizeofType x0 (fromLoc l)) reloc l (Cast x0 x1 _) = (Cast x0 x1 (fromLoc l)) reloc l (Cond x0 x1 x2 _) = (Cond x0 x1 x2 (fromLoc l)) reloc l (Member x0 x1 _) = (Member x0 x1 (fromLoc l)) reloc l (PtrMember x0 x1 _) = (PtrMember x0 x1 (fromLoc l)) reloc l (Index x0 x1 _) = (Index x0 x1 (fromLoc l)) reloc l (FnCall x0 x1 _) = (FnCall x0 x1 (fromLoc l)) reloc l (CudaCall x0 x1 x2 _) = (CudaCall x0 x1 x2 (fromLoc l)) reloc l (Seq x0 x1 _) = (Seq x0 x1 (fromLoc l)) reloc l (CompoundLit x0 x1 _) = (CompoundLit x0 x1 (fromLoc l)) reloc l (StmExpr x0 _) = (StmExpr x0 (fromLoc l)) reloc l (EscExp x0 _) = (EscExp x0 (fromLoc l)) reloc l (AntiEscExp x0 _) = (AntiEscExp x0 (fromLoc l)) reloc l (AntiExp x0 _) = (AntiExp x0 (fromLoc l)) reloc l (AntiArgs x0 _) = (AntiArgs x0 (fromLoc l)) reloc l (BuiltinVaArg x0 x1 _) = (BuiltinVaArg x0 x1 (fromLoc l)) reloc l (BlockLit x0 x1 x2 _) = (BlockLit x0 x1 x2 (fromLoc l)) reloc l (ObjCMsg x0 x1 x2 _) = (ObjCMsg x0 x1 x2 (fromLoc l)) reloc l (ObjCLitConst x0 x1 _) = (ObjCLitConst x0 x1 (fromLoc l)) reloc l (ObjCLitString x0 _) = (ObjCLitString x0 (fromLoc l)) reloc l (ObjCLitBool x0 _) = (ObjCLitBool x0 (fromLoc l)) reloc l (ObjCLitArray x0 _) = (ObjCLitArray x0 (fromLoc l)) reloc l (ObjCLitDict x0 _) = (ObjCLitDict x0 (fromLoc l)) reloc l (ObjCLitBoxed x0 _) = (ObjCLitBoxed x0 (fromLoc l)) reloc l (ObjCEncode x0 _) = (ObjCEncode x0 (fromLoc l)) reloc l (ObjCProtocol x0 _) = (ObjCProtocol x0 (fromLoc l)) reloc l (ObjCSelector x0 _) = (ObjCSelector x0 (fromLoc l)) reloc l (Lambda x0 x1 x2 _) = (Lambda x0 x1 x2 (fromLoc l)) instance Relocatable LambdaIntroducer where reloc l (LambdaIntroducer x0 _) = (LambdaIntroducer x0 (fromLoc l)) instance Relocatable LambdaDeclarator where reloc l (LambdaDeclarator x0 x1 x2 _) = (LambdaDeclarator x0 x1 x2 (fromLoc l)) instance Relocatable BlockType where reloc l (BlockVoid _) = (BlockVoid (fromLoc l)) reloc l (BlockParam x0 _) = (BlockParam x0 (fromLoc l)) reloc l (BlockType x0 _) = (BlockType x0 (fromLoc l)) instance Relocatable ExeConfig where reloc l (ExeConfig x0 x1 x2 x3 _) = (ExeConfig x0 x1 x2 x3 (fromLoc l)) instance Relocatable ObjCIvarDecl where reloc l (ObjCIvarVisi x0 _) = (ObjCIvarVisi x0 (fromLoc l)) reloc l (ObjCIvarDecl x0 _) = (ObjCIvarDecl x0 (fromLoc l)) instance Relocatable ObjCVisibilitySpec where reloc l (ObjCPrivate _) = (ObjCPrivate (fromLoc l)) reloc l (ObjCPublic _) = (ObjCPublic (fromLoc l)) reloc l (ObjCProtected _) = (ObjCProtected (fromLoc l)) reloc l (ObjCPackage _) = (ObjCPackage (fromLoc l)) instance Relocatable ObjCIfaceDecl where reloc l (ObjCIfaceProp x0 x1 _) = (ObjCIfaceProp x0 x1 (fromLoc l)) reloc l (ObjCIfaceReq x0 _) = (ObjCIfaceReq x0 (fromLoc l)) reloc l (ObjCIfaceMeth x0 _) = (ObjCIfaceMeth x0 (fromLoc l)) reloc l (ObjCIfaceDecl x0 _) = (ObjCIfaceDecl x0 (fromLoc l)) reloc l (AntiObjCProp x0 _) = (AntiObjCProp x0 (fromLoc l)) reloc l (AntiObjCProps x0 _) = (AntiObjCProps x0 (fromLoc l)) reloc l (AntiObjCIfaceDecl x0 _) = (AntiObjCIfaceDecl x0 (fromLoc l)) reloc l (AntiObjCIfaceDecls x0 _) = (AntiObjCIfaceDecls x0 (fromLoc l)) instance Relocatable ObjCPropAttr where reloc l (ObjCGetter x0 _) = (ObjCGetter x0 (fromLoc l)) reloc l (ObjCSetter x0 _) = (ObjCSetter x0 (fromLoc l)) reloc l (ObjCReadonly _) = (ObjCReadonly (fromLoc l)) reloc l (ObjCReadwrite _) = (ObjCReadwrite (fromLoc l)) reloc l (ObjCAssign _) = (ObjCAssign (fromLoc l)) reloc l (ObjCRetain _) = (ObjCRetain (fromLoc l)) reloc l (ObjCCopy _) = (ObjCCopy (fromLoc l)) reloc l (ObjCNonatomic _) = (ObjCNonatomic (fromLoc l)) reloc l (ObjCAtomic _) = (ObjCAtomic (fromLoc l)) reloc l (ObjCStrong _) = (ObjCStrong (fromLoc l)) reloc l (ObjCWeak _) = (ObjCWeak (fromLoc l)) reloc l (ObjCUnsafeUnretained _) = (ObjCUnsafeUnretained (fromLoc l)) reloc l (AntiObjCAttr x0 _) = (AntiObjCAttr x0 (fromLoc l)) reloc l (AntiObjCAttrs x0 _) = (AntiObjCAttrs x0 (fromLoc l)) instance Relocatable ObjCMethodReq where reloc l (ObjCRequired _) = (ObjCRequired (fromLoc l)) reloc l (ObjCOptional _) = (ObjCOptional (fromLoc l)) instance Relocatable ObjCParam where reloc l (ObjCParam x0 x1 x2 x3 _) = (ObjCParam x0 x1 x2 x3 (fromLoc l)) reloc l (AntiObjCParam x0 _) = (AntiObjCParam x0 (fromLoc l)) reloc l (AntiObjCParams x0 _) = (AntiObjCParams x0 (fromLoc l)) instance Relocatable ObjCMethodProto where reloc l (ObjCMethodProto x0 x1 x2 x3 x4 x5 _) = (ObjCMethodProto x0 x1 x2 x3 x4 x5 (fromLoc l)) reloc l (AntiObjCMethodProto x0 _) = (AntiObjCMethodProto x0 (fromLoc l)) instance Relocatable ObjCCatch where reloc l (ObjCCatch x0 x1 _) = (ObjCCatch x0 x1 (fromLoc l)) instance Relocatable ObjCRecv where reloc l (ObjCRecvSuper _) = (ObjCRecvSuper (fromLoc l)) reloc l (ObjCRecvExp x0 _) = (ObjCRecvExp x0 (fromLoc l)) reloc l (AntiObjCRecv x0 _) = (AntiObjCRecv x0 (fromLoc l)) instance Relocatable ObjCArg where reloc l (ObjCArg x0 x1 _) = (ObjCArg x0 x1 (fromLoc l)) reloc l (AntiObjCArg x0 _) = (AntiObjCArg x0 (fromLoc l)) reloc l (AntiObjCArgs x0 _) = (AntiObjCArgs x0 (fromLoc l)) instance Relocatable ObjCDictElem where reloc l (ObjCDictElem x0 x1 _) = (ObjCDictElem x0 x1 (fromLoc l)) reloc l (AntiObjCDictElems x0 _) = (AntiObjCDictElems x0 (fromLoc l)) language-c-quote-0.13.0.2/Language/C/Syntax.hs0000644000000000000000000005245207346545000017021 0ustar0000000000000000-- | -- Module : Language.C.Syntax -- Copyright : (c) 2006-2011 Harvard University -- (c) 2011-2013 Geoffrey Mainland -- (c) 2013 Manuel M T Chakravarty -- : (c) 2013-2016 Drexel University -- License : BSD-style -- Maintainer : mainland@drexel.edu {-# LANGUAGE CPP #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE FlexibleInstances #-} module Language.C.Syntax where import Data.Data (Data(..)) import Data.Loc import Data.String (IsString(..)) import Data.Typeable (Typeable) data Extensions = Antiquotation | C99 | C11 | Gcc | Blocks | ObjC | CUDA | OpenCL deriving (Eq, Ord, Enum, Show) data Id = Id String !SrcLoc | AntiId String !SrcLoc deriving (Eq, Ord, Show, Data, Typeable) data StringLit = StringLit [String] String !SrcLoc deriving (Eq, Ord, Show, Data, Typeable) type Linkage = StringLit data Storage = Tauto !SrcLoc | Tregister !SrcLoc | Tstatic !SrcLoc | Textern (Maybe Linkage) !SrcLoc | Ttypedef !SrcLoc -- Clang blocks | T__block !SrcLoc -- Objective-C | TObjC__weak !SrcLoc | TObjC__strong !SrcLoc | TObjC__unsafe_unretained !SrcLoc deriving (Eq, Ord, Show, Data, Typeable) data TypeQual = Tconst !SrcLoc | Tvolatile !SrcLoc | EscTypeQual String !SrcLoc | AntiTypeQual String !SrcLoc | AntiTypeQuals String !SrcLoc -- C99 | Tinline !SrcLoc | Trestrict !SrcLoc -- GCC | T__restrict !SrcLoc | TAttr Attr -- CUDA | TCUDAdevice !SrcLoc | TCUDAglobal !SrcLoc | TCUDAhost !SrcLoc | TCUDAconstant !SrcLoc | TCUDAshared !SrcLoc | TCUDArestrict !SrcLoc | TCUDAnoinline !SrcLoc -- OpenCL | TCLprivate !SrcLoc | TCLlocal !SrcLoc | TCLglobal !SrcLoc | TCLconstant !SrcLoc | TCLreadonly !SrcLoc | TCLwriteonly !SrcLoc | TCLkernel !SrcLoc deriving (Eq, Ord, Show, Data, Typeable) data Sign = Tsigned !SrcLoc | Tunsigned !SrcLoc deriving (Eq, Ord, Show, Data, Typeable) data TypeSpec = Tvoid !SrcLoc | Tchar (Maybe Sign) !SrcLoc | Tshort (Maybe Sign) !SrcLoc | Tint (Maybe Sign) !SrcLoc | Tlong (Maybe Sign) !SrcLoc | Tlong_long (Maybe Sign) !SrcLoc | Tfloat !SrcLoc | Tdouble !SrcLoc | Tlong_double !SrcLoc | Tstruct (Maybe Id) (Maybe [FieldGroup]) [Attr] !SrcLoc | Tunion (Maybe Id) (Maybe [FieldGroup]) [Attr] !SrcLoc | Tenum (Maybe Id) [CEnum] [Attr] !SrcLoc | Tnamed Id -- A typedef name [Id] -- Objective-C protocol references !SrcLoc -- C99 | T_Bool !SrcLoc | Tfloat_Complex !SrcLoc | Tdouble_Complex !SrcLoc | Tlong_double_Complex !SrcLoc | Tfloat_Imaginary !SrcLoc | Tdouble_Imaginary !SrcLoc | Tlong_double_Imaginary !SrcLoc -- Gcc | TtypeofExp Exp !SrcLoc | TtypeofType Type !SrcLoc | Tva_list !SrcLoc deriving (Eq, Ord, Show, Data, Typeable) data DeclSpec = DeclSpec [Storage] [TypeQual] TypeSpec !SrcLoc | AntiDeclSpec String !SrcLoc | AntiTypeDeclSpec [Storage] [TypeQual] String !SrcLoc deriving (Eq, Ord, Show, Data, Typeable) -- | There are two types of declarators in C, regular declarators and abstract -- declarators. The former is for declaring variables, function parameters, -- typedefs, etc. and the latter for abstract types---@typedef int -- ({*}foo)(void)@ vs. @\tt int ({*})(void)@. The difference between the two is -- just whether or not an identifier is attached to the declarator. We therefore -- only define one 'Decl' type and use it for both cases. data ArraySize = ArraySize Bool Exp !SrcLoc | VariableArraySize !SrcLoc | NoArraySize !SrcLoc deriving (Eq, Ord, Show, Data, Typeable) data Decl = DeclRoot !SrcLoc | Ptr [TypeQual] Decl !SrcLoc | Array [TypeQual] ArraySize Decl !SrcLoc | Proto Decl Params !SrcLoc | OldProto Decl [Id] !SrcLoc | AntiTypeDecl String !SrcLoc -- Clang blocks | BlockPtr [TypeQual] Decl !SrcLoc deriving (Eq, Ord, Show, Data, Typeable) data Type = Type DeclSpec Decl !SrcLoc | AntiType String !SrcLoc deriving (Eq, Ord, Show, Data, Typeable) data Designator = IndexDesignator Exp !SrcLoc | MemberDesignator Id !SrcLoc deriving (Eq, Ord, Show, Data, Typeable) data Designation = Designation [Designator] !SrcLoc deriving (Eq, Ord, Show, Data, Typeable) data Initializer = ExpInitializer Exp !SrcLoc | CompoundInitializer [(Maybe Designation, Initializer)] !SrcLoc | AntiInit String !SrcLoc | AntiInits String !SrcLoc deriving (Eq, Ord, Show, Data, Typeable) type AsmLabel = StringLit data Init = Init Id Decl (Maybe AsmLabel) (Maybe Initializer) [Attr] !SrcLoc deriving (Eq, Ord, Show, Data, Typeable) data Typedef = Typedef Id Decl [Attr] !SrcLoc deriving (Eq, Ord, Show, Data, Typeable) data InitGroup = InitGroup DeclSpec [Attr] [Init] !SrcLoc | TypedefGroup DeclSpec [Attr] [Typedef] !SrcLoc | AntiDecl String !SrcLoc | AntiDecls String !SrcLoc deriving (Eq, Ord, Show, Data, Typeable) data Field = Field (Maybe Id) (Maybe Decl) (Maybe Exp) !SrcLoc deriving (Eq, Ord, Show, Data, Typeable) data FieldGroup = FieldGroup DeclSpec [Field] !SrcLoc | AntiSdecl String !SrcLoc | AntiSdecls String !SrcLoc deriving (Eq, Ord, Show, Data, Typeable) data CEnum = CEnum Id (Maybe Exp) !SrcLoc | AntiEnum String !SrcLoc | AntiEnums String !SrcLoc deriving (Eq, Ord, Show, Data, Typeable) data Attr = Attr Id [Exp] !SrcLoc | AntiAttr String !SrcLoc | AntiAttrs String !SrcLoc deriving (Eq, Ord, Show, Data, Typeable) data Param = Param (Maybe Id) DeclSpec Decl !SrcLoc | AntiParam String !SrcLoc | AntiParams String !SrcLoc deriving (Eq, Ord, Show, Data, Typeable) data Params = Params [Param] Bool !SrcLoc deriving (Eq, Ord, Show, Data, Typeable) data Func = Func DeclSpec Id Decl Params [BlockItem] !SrcLoc | OldFunc DeclSpec Id Decl [Id] (Maybe [InitGroup]) [BlockItem] !SrcLoc deriving (Eq, Ord, Show, Data, Typeable) data Definition = FuncDef Func !SrcLoc | DecDef InitGroup !SrcLoc | EscDef String !SrcLoc | AntiFunc String !SrcLoc | AntiEsc String !SrcLoc | AntiEdecl String !SrcLoc | AntiEdecls String !SrcLoc -- Objective-C | ObjCClassDec [Id] !SrcLoc | ObjCClassIface Id (Maybe Id) [Id] [ObjCIvarDecl] [ObjCIfaceDecl] [Attr] !SrcLoc | ObjCCatIface Id (Maybe Id) [Id] [ObjCIvarDecl] [ObjCIfaceDecl] !SrcLoc | ObjCProtDec [Id] !SrcLoc | ObjCProtDef Id [Id] [ObjCIfaceDecl] !SrcLoc | ObjCClassImpl Id (Maybe Id) [ObjCIvarDecl] [Definition] !SrcLoc | ObjCCatImpl Id Id [Definition] !SrcLoc | ObjCSynDef [(Id, Maybe Id)] !SrcLoc | ObjCDynDef [Id] !SrcLoc | ObjCMethDef ObjCMethodProto [BlockItem] !SrcLoc | ObjCCompAlias Id Id !SrcLoc | AntiObjCMeth String !SrcLoc | AntiObjCMeths String !SrcLoc deriving (Eq, Ord, Show, Data, Typeable) data Stm = Label Id [Attr] Stm !SrcLoc | Case Exp Stm !SrcLoc | CaseRange Exp Exp Stm !SrcLoc | Default Stm !SrcLoc | Exp (Maybe Exp) !SrcLoc | Block [BlockItem] !SrcLoc | If Exp Stm (Maybe Stm) !SrcLoc | Switch Exp Stm !SrcLoc | While Exp Stm !SrcLoc | DoWhile Stm Exp !SrcLoc | For (Either InitGroup (Maybe Exp)) (Maybe Exp) (Maybe Exp) Stm !SrcLoc | Goto Id !SrcLoc | Continue !SrcLoc | Break !SrcLoc | Return (Maybe Exp) !SrcLoc | Pragma String !SrcLoc | Comment String Stm !SrcLoc | EscStm String !SrcLoc | AntiEscStm String !SrcLoc | AntiPragma String !SrcLoc | AntiComment String Stm !SrcLoc | AntiStm String !SrcLoc | AntiStms String !SrcLoc -- GCC | Asm Bool -- @True@ if volatile, @False@ otherwise [Attr] -- Attributes AsmTemplate -- Assembly template [AsmOut] -- Output operands [AsmIn] -- Input operands [AsmClobber] -- Clobbered registers !SrcLoc | AsmGoto Bool -- @True@ if volatile, @False@ otherwise [Attr] -- Attributes AsmTemplate -- Assembly template [AsmIn] -- Input operands [AsmClobber] -- Clobbered registers [Id] -- Labels !SrcLoc -- Objective-C | ObjCTry [BlockItem] [ObjCCatch] (Maybe [BlockItem]) !SrcLoc -- ^Invariant: There is either at least one 'ObjCCatch' or the finally block is present. | ObjCThrow (Maybe Exp) !SrcLoc | ObjCSynchronized Exp [BlockItem] !SrcLoc | ObjCAutoreleasepool [BlockItem] !SrcLoc deriving (Eq, Ord, Show, Data, Typeable) data BlockItem = BlockDecl InitGroup | BlockStm Stm | AntiBlockItem String !SrcLoc | AntiBlockItems String !SrcLoc deriving (Eq, Ord, Show, Data, Typeable) data Signed = Signed | Unsigned deriving (Eq, Ord, Show, Data, Typeable) -- | The 'String' parameter to 'Const' data constructors is the raw string -- representation of the constant as it was parsed. data Const = IntConst String Signed Integer !SrcLoc | LongIntConst String Signed Integer !SrcLoc | LongLongIntConst String Signed Integer !SrcLoc | FloatConst String Float !SrcLoc | DoubleConst String Double !SrcLoc | LongDoubleConst String Double !SrcLoc | CharConst String Char !SrcLoc | StringConst [String] String !SrcLoc | AntiConst String !SrcLoc | AntiInt String !SrcLoc | AntiUInt String !SrcLoc | AntiLInt String !SrcLoc | AntiULInt String !SrcLoc | AntiLLInt String !SrcLoc | AntiULLInt String !SrcLoc | AntiFloat String !SrcLoc | AntiDouble String !SrcLoc | AntiLongDouble String !SrcLoc | AntiChar String !SrcLoc | AntiString String !SrcLoc deriving (Eq, Ord, Show, Data, Typeable) data Exp = Var Id !SrcLoc | Const Const !SrcLoc | BinOp BinOp Exp Exp !SrcLoc | Assign Exp AssignOp Exp !SrcLoc | PreInc Exp !SrcLoc | PostInc Exp !SrcLoc | PreDec Exp !SrcLoc | PostDec Exp !SrcLoc | UnOp UnOp Exp !SrcLoc | SizeofExp Exp !SrcLoc | SizeofType Type !SrcLoc | Cast Type Exp !SrcLoc | Cond Exp Exp Exp !SrcLoc | Member Exp Id !SrcLoc | PtrMember Exp Id !SrcLoc | Index Exp Exp !SrcLoc | FnCall Exp [Exp] !SrcLoc | CudaCall Exp ExeConfig [Exp] !SrcLoc | Seq Exp Exp !SrcLoc | CompoundLit Type [(Maybe Designation, Initializer)] !SrcLoc | StmExpr [BlockItem] !SrcLoc | EscExp String !SrcLoc | AntiEscExp String !SrcLoc | AntiExp String !SrcLoc | AntiArgs String !SrcLoc -- GCC | BuiltinVaArg Exp Type !SrcLoc -- Clang blocks | BlockLit BlockType [Attr] [BlockItem] !SrcLoc -- Objective-C | ObjCMsg ObjCRecv [ObjCArg] [Exp] !SrcLoc -- ^Invariant: First argument must at least have either a selector or an expression; -- all other arguments must have an expression. | ObjCLitConst (Maybe UnOp) Const -- Anything except 'StringConst' !SrcLoc | ObjCLitString [Const] -- Must all be 'StringConst' !SrcLoc | ObjCLitBool Bool !SrcLoc | ObjCLitArray [Exp] !SrcLoc | ObjCLitDict [ObjCDictElem] !SrcLoc | ObjCLitBoxed Exp !SrcLoc | ObjCEncode Type !SrcLoc | ObjCProtocol Id !SrcLoc | ObjCSelector String !SrcLoc -- CUDA: C++11 lambda-expression | Lambda LambdaIntroducer (Maybe LambdaDeclarator) [BlockItem] !SrcLoc deriving (Eq, Ord, Show, Data, Typeable) data BinOp = Add | Sub | Mul | Div | Mod | Eq | Ne | Lt | Gt | Le | Ge | Land | Lor | And | Or | Xor | Lsh | Rsh deriving (Eq, Ord, Show, Data, Typeable) data AssignOp = JustAssign | AddAssign | SubAssign | MulAssign | DivAssign | ModAssign | LshAssign | RshAssign | AndAssign | XorAssign | OrAssign deriving (Eq, Ord, Show, Data, Typeable) data UnOp = AddrOf | Deref | Positive | Negate | Not | Lnot deriving (Eq, Ord, Show, Data, Typeable) {------------------------------------------------------------------------------ - - GCC extensions - ------------------------------------------------------------------------------} type AsmTemplate = StringLit data AsmOut = AsmOut (Maybe Id) String Id deriving (Eq, Ord, Show, Data, Typeable) data AsmIn = AsmIn (Maybe Id) String Exp deriving (Eq, Ord, Show, Data, Typeable) type AsmClobber = String {------------------------------------------------------------------------------ - - Clang blocks - ------------------------------------------------------------------------------} data BlockType = BlockVoid !SrcLoc | BlockParam [Param] !SrcLoc | BlockType Type !SrcLoc -- NB: Type may be something other than 'Proto', in which case clang defaults to -- regard the type as the return type and assume the arguments to be 'void'. deriving (Eq, Ord, Show, Data, Typeable) {------------------------------------------------------------------------------ - - Objective-C - ------------------------------------------------------------------------------} data ObjCIvarDecl = ObjCIvarVisi ObjCVisibilitySpec !SrcLoc | ObjCIvarDecl FieldGroup !SrcLoc -- -=chak FIXME: needs ANTI forms deriving (Eq, Ord, Show, Data, Typeable) data ObjCVisibilitySpec = ObjCPrivate !SrcLoc | ObjCPublic !SrcLoc | ObjCProtected !SrcLoc | ObjCPackage !SrcLoc deriving (Eq, Ord, Show, Data, Typeable) data ObjCIfaceDecl = ObjCIfaceProp [ObjCPropAttr] FieldGroup !SrcLoc | ObjCIfaceReq ObjCMethodReq !SrcLoc | ObjCIfaceMeth ObjCMethodProto !SrcLoc | ObjCIfaceDecl InitGroup !SrcLoc | AntiObjCProp String !SrcLoc | AntiObjCProps String !SrcLoc | AntiObjCIfaceDecl String !SrcLoc | AntiObjCIfaceDecls String !SrcLoc deriving (Eq, Ord, Show, Data, Typeable) data ObjCPropAttr = ObjCGetter Id !SrcLoc | ObjCSetter Id !SrcLoc | ObjCReadonly !SrcLoc | ObjCReadwrite !SrcLoc | ObjCAssign !SrcLoc | ObjCRetain !SrcLoc | ObjCCopy !SrcLoc | ObjCNonatomic !SrcLoc | ObjCAtomic !SrcLoc | ObjCStrong !SrcLoc | ObjCWeak !SrcLoc | ObjCUnsafeUnretained !SrcLoc | AntiObjCAttr String !SrcLoc | AntiObjCAttrs String !SrcLoc deriving (Eq, Ord, Show, Data, Typeable) data ObjCMethodReq = ObjCRequired !SrcLoc | ObjCOptional !SrcLoc deriving (Eq, Ord, Show, Data, Typeable) data ObjCParam = ObjCParam (Maybe Id) (Maybe Type) [Attr] (Maybe Id) !SrcLoc | AntiObjCParam String !SrcLoc | AntiObjCParams String !SrcLoc deriving (Eq, Ord, Show, Data, Typeable) data ObjCMethodProto = ObjCMethodProto Bool (Maybe Type) [Attr] [ObjCParam] Bool [Attr] !SrcLoc -- ^Invariant: First parameter must at least either have a selector or -- an identifier; all other parameters must have an identifier. | AntiObjCMethodProto String !SrcLoc deriving (Eq, Ord, Show, Data, Typeable) data ObjCCatch = ObjCCatch (Maybe Param) [BlockItem] !SrcLoc deriving (Eq, Ord, Show, Data, Typeable) data ObjCDictElem = ObjCDictElem Exp Exp !SrcLoc | AntiObjCDictElems String !SrcLoc deriving (Eq, Ord, Show, Data, Typeable) data ObjCRecv = ObjCRecvSuper !SrcLoc | ObjCRecvExp Exp !SrcLoc | AntiObjCRecv String !SrcLoc deriving (Eq, Ord, Show, Data, Typeable) data ObjCArg = ObjCArg (Maybe Id) (Maybe Exp) !SrcLoc | AntiObjCArg String !SrcLoc | AntiObjCArgs String !SrcLoc deriving (Eq, Ord, Show, Data, Typeable) {------------------------------------------------------------------------------ - - CUDA - ------------------------------------------------------------------------------} data LambdaIntroducer = LambdaIntroducer [CaptureListEntry] !SrcLoc deriving (Eq, Ord, Show, Data, Typeable) data LambdaDeclarator = LambdaDeclarator Params Bool (Maybe Type) !SrcLoc deriving (Eq, Ord, Show, Data, Typeable) data CaptureListEntry = DefaultByReference | DefaultByValue deriving (Eq, Ord, Show, Data, Typeable) data ExeConfig = ExeConfig { exeGridDim :: Exp , exeBlockDim :: Exp , exeSharedSize :: Maybe Exp , exeStream :: Maybe Exp , exeLoc :: !SrcLoc } deriving (Eq, Ord, Show, Data, Typeable) {------------------------------------------------------------------------------ - - Instances - ------------------------------------------------------------------------------} instance IsString Id where fromString s = Id s noLoc instance IsString StringLit where fromString s = StringLit [s] s noLoc #if !defined(ONLY_TYPEDEFS) #include "Language/C/Syntax-instances.hs" {------------------------------------------------------------------------------ - - Utilities - ------------------------------------------------------------------------------} funcProto :: Func -> InitGroup funcProto f@(Func decl_spec ident decl params _ _) = InitGroup decl_spec [] [Init ident (Proto decl params l) Nothing Nothing [] l] l where l = srclocOf f funcProto f@(OldFunc decl_spec ident decl params _ _ _) = InitGroup decl_spec [] [Init ident (OldProto decl params l) Nothing Nothing [] l] l where l = srclocOf f isPtr :: Type -> Bool isPtr (Type _ decl _) = go decl where go (DeclRoot _) = False go (Ptr _ _ _) = True go (BlockPtr _ _ _) = True go (Array _ _ _ _) = True go (Proto _ _ _) = False go (OldProto _ _ _) = False go (AntiTypeDecl _ _) = error "isPtr: encountered antiquoted type declaration" isPtr (AntiType _ _) = error "isPtr: encountered antiquoted type" ctypedef :: Id -> Decl -> [Attr] -> Typedef ctypedef ident decl attrs = Typedef ident decl attrs (ident `srcspan` decl `srcspan` attrs) cdeclSpec :: [Storage] -> [TypeQual] -> TypeSpec -> DeclSpec cdeclSpec storage quals spec = DeclSpec storage quals spec (storage `srcspan` quals `srcspan` spec) cinitGroup :: DeclSpec -> [Attr] -> [Init] -> InitGroup cinitGroup dspec attrs inis = InitGroup dspec attrs inis (dspec `srcspan` attrs `srcspan` inis) ctypedefGroup :: DeclSpec -> [Attr] -> [Typedef] -> InitGroup ctypedefGroup dspec attrs typedefs = TypedefGroup dspec attrs typedefs (dspec `srcspan` attrs `srcspan` typedefs) #endif /* !defined(ONLY_TYPEDEFS) */ language-c-quote-0.13.0.2/Setup.hs0000644000000000000000000000005707346545000014720 0ustar0000000000000000import Distribution.Simple main = defaultMain language-c-quote-0.13.0.2/language-c-quote.cabal0000644000000000000000000000751207346545000017411 0ustar0000000000000000name: language-c-quote version: 0.13.0.2 cabal-version: 2.0 license: BSD3 license-file: LICENSE copyright: (c) 2006-2011 Harvard University (c) 2011-2013 Geoffrey Mainland (c) 2013 Manuel M. T. Chakravarty (c) 2013-2024 Drexel University author: Geoffrey Mainland maintainer: Geoffrey Mainland stability: alpha homepage: https://github.com/mainland/language-c-quote bug-reports: https://github.com/mainland/language-c-quote/issues category: Language synopsis: C/CUDA/OpenCL/Objective-C quasiquoting library. tested-with: GHC==8.0.2, GHC==8.2.2, GHC==8.4.3, GHC==8.6.5, GHC==8.8.4, GHC==8.10.7, GHC==9.0.2, GHC==9.2.2, GHC==9.4.8, GHC==9.6.4, GHC==9.8.2, GHC==9.10.1 description: This package provides a general parser for the C language, including most GCC extensions and some CUDA and OpenCL extensions as well as the entire Objective-C language. build-type: Simple extra-source-files: Language/C/Syntax-instances.hs CHANGELOG.md flag full-haskell-antiquotes description: Support full Haskell expressions/patterns in antiquotes. This adds a dependency on haskell-src-meta, which increases compilation time. default: True manual: True library default-language: Haskell2010 build-depends: array >= 0.2 && < 0.6, base >= 4.5 && < 5, bytestring >= 0.9 && < 0.13, containers >= 0.4 && < 0.8, exception-mtl >= 0.3 && < 0.5, exception-transformers >= 0.3 && < 0.5, filepath >= 1.2 && < 1.6, mainland-pretty >= 0.7 && < 0.8, mtl >= 2.0 && < 3, srcloc >= 0.4 && < 0.7, syb >= 0.3 && < 0.8, template-haskell if flag(full-haskell-antiquotes) if impl(ghc < 7.8) build-depends: safe <= 0.3.9 if impl(ghc >= 8.0) && impl(ghc < 8.1) build-depends: haskell-src-meta >= 0.4 && < 0.8.7 else if impl(ghc >= 7.6) build-depends: haskell-src-meta >= 0.4 && < 0.9 else build-depends: haskell-src-meta >= 0.4 && < 0.7 else build-depends: haskell-exp-parser >= 0.1 && < 0.2 if impl(ghc < 7.4) build-tool-depends: alex:alex, happy:happy if impl(ghc >= 7.4) build-tool-depends: alex:alex >=3, happy:happy exposed-modules: Language.C Language.C.Parser Language.C.Parser.Lexer Language.C.Parser.Monad Language.C.Parser.Parser Language.C.Parser.Tokens Language.C.Pretty Language.C.Quote Language.C.Quote.Base Language.C.Quote.C Language.C.Quote.CUDA Language.C.Quote.GCC Language.C.Quote.ObjC Language.C.Quote.OpenCL Language.C.Smart Language.C.Syntax include-dirs: . ghc-options: -Wall if flag(full-haskell-antiquotes) cpp-options: -DFULL_HASKELL_ANTIQUOTES test-suite unit type: exitcode-stdio-1.0 hs-source-dirs: tests/unit main-is: Main.hs other-modules: CUDA GCC Objc MainCPP default-language: Haskell2010 build-depends: HUnit >= 1.2 && < 1.7, base >= 4 && < 5, bytestring >= 0.9 && < 0.13, language-c-quote, mainland-pretty >= 0.7 && < 0.8, srcloc >= 0.4 && < 0.7, test-framework >= 0.8 && < 0.9, test-framework-hunit >= 0.3 && < 0.4 if flag(full-haskell-antiquotes) cpp-options: -DFULL_HASKELL_ANTIQUOTES source-repository head type: git location: git://github.com/mainland/language-c-quote.git language-c-quote-0.13.0.2/tests/unit/0000755000000000000000000000000007346545000015403 5ustar0000000000000000language-c-quote-0.13.0.2/tests/unit/CUDA.hs0000644000000000000000000000526107346545000016457 0ustar0000000000000000{-# LANGUAGE QuasiQuotes #-} module CUDA (cudaTests) where import Test.Framework import Test.Framework.Providers.HUnit import Test.HUnit (Assertion, (@?=)) import Language.C.Quote.CUDA import Language.C.Syntax import Data.Loc (noLoc) mkDeclarator :: [Param] -> Bool -> LambdaDeclarator mkDeclarator params mutability = LambdaDeclarator (Params params False noLoc) mutability Nothing noLoc mkIntroducer :: [CaptureListEntry] -> LambdaIntroducer mkIntroducer mode = (LambdaIntroducer mode noLoc) emptyLambda :: Exp emptyLambda = lambdaByCapture [] lambdaByCapture :: [CaptureListEntry] -> Exp lambdaByCapture captureMode = Lambda (mkIntroducer captureMode) Nothing [] noLoc lambdaByCaptureBody :: [CaptureListEntry] -> [BlockItem] -> Exp lambdaByCaptureBody captureMode statements = Lambda (mkIntroducer captureMode) Nothing statements noLoc lambdaByCaptureParams :: [CaptureListEntry] -> [Param] -> Exp lambdaByCaptureParams captureMode params = Lambda (mkIntroducer captureMode) (Just $ mkDeclarator params False) [] noLoc lambdaByParams :: [Param] -> Exp lambdaByParams params = Lambda (mkIntroducer []) (Just $ mkDeclarator params False) [] noLoc mutableLambdaByParams :: [Param] -> Exp mutableLambdaByParams params = Lambda (mkIntroducer []) (Just $ mkDeclarator params True) [] noLoc cudaTests :: Test cudaTests = testGroup "CUDA" $ map (testCase "lambda-expressions parsing") lambdas where lambdas :: [Assertion] lambdas = [ [cexp|[=] {}|] @?= lambdaByCapture [DefaultByValue] , [cexp|[&] {}|] @?= lambdaByCapture[DefaultByReference] , [cexp|[] {}|] @?= lambdaByCapture [] , [cexp|[] {}|] @?= emptyLambda , [cexp|[] () {}|] @?= lambdaByParams [] , [cexp|[] (int i) {}|] @?= lambdaByParams [param_int_i] , [cexp|[] (int i, double j) {}|] @?= lambdaByParams [param_int_i, param_double_h] , [cexp|[] ($param:param_int_i) {}|] @?= lambdaByParams [param_int_i] , [cexp|[] (int i) mutable {}|] @?= mutableLambdaByParams [param_int_i] , [cexp|[&] (int i) {}|] @?= lambdaByCaptureParams [DefaultByReference] [param_int_i] , [cexp|[&] { $item:item_return_7 } |] @?= lambdaCapturingByRefAndReturning7 , [cexp|[&] { return $exp:exp_7; } |] @?= lambdaCapturingByRefAndReturning7 , [cexp|[]{}()|] @?= FnCall emptyLambda [] noLoc , [cexp|[](){}()|] @?= FnCall (lambdaByParams []) [] noLoc ] lambdaCapturingByRefAndReturning7 = lambdaByCaptureBody [DefaultByReference] [item_return_7] exp_7 = [cexp|7|] item_return_7 = [citem|return 7;|] param_int_i = [cparam|int i|] param_double_h = [cparam|double j|] language-c-quote-0.13.0.2/tests/unit/GCC.hs0000644000000000000000000000351207346545000016334 0ustar0000000000000000{-# LANGUAGE QuasiQuotes #-} module GCC ( gccTests ) where import Test.Framework import Test.Framework.Providers.HUnit import Test.HUnit (Assertion, assert, (@?=)) import qualified Data.ByteString.Char8 as B import Data.Char (isSpace) import Data.Loc (SrcLoc, noLoc, startPos) import Control.Exception (SomeException) import Language.C.Quote.GCC import Language.C.Smart () import qualified Language.C.Syntax as C import qualified Language.C.Parser as P import Text.PrettyPrint.Mainland import Text.PrettyPrint.Mainland.Class gccTests :: Test gccTests = testGroup "GCC attribute quotations" [ testCase "attr antiquote" test_attr , testCase "attrs antiquote" test_attrs , testCase "attrs antiquote pretty" test_attr_p , testCase "case ranges quote" test_case_ranges , testCase "case ranges pretty" test_case_ranges_p ] where test_attr :: Assertion test_attr = [cedecl| int test __attribute__(($attr:a,$attr:b));|] @?= [cedecl| int test __attribute__((section(".sram2"), noinit));|] where a = [cattr| section(".sram2") |] b = [cattr| noinit |] test_attrs :: Assertion test_attrs = [cedecl| int test __attribute__(($attrs:as));|] @?= [cedecl| int test __attribute__((section(".sram2"), noinit));|] where a = [cattr| section(".sram2") |] b = [cattr| noinit |] as = [ a, b ] test_attr_p :: Assertion test_attr_p = pretty 80 (ppr [cattr|section(".sram2")|]) @?= "section(\".sram2\")" test_case_ranges :: Assertion test_case_ranges = assert $ case [cstm| case 10 ... 20: ; |] of C.CaseRange 10 20 (C.Exp Nothing _) _ -> True _ -> False test_case_ranges_p :: Assertion test_case_ranges_p = pretty 80 (ppr [cstm| case 10 ... 20: ; |]) @?= "\ncase 10 ... 20:\n;" language-c-quote-0.13.0.2/tests/unit/Main.hs0000644000000000000000000004665707346545000016645 0ustar0000000000000000{-# LANGUAGE QuasiQuotes #-} module Main where import Test.Framework import Test.Framework.Providers.HUnit import Test.HUnit (Assertion, (@?=)) import qualified Data.ByteString.Char8 as B import Data.Char (isSpace) import Data.Loc (SrcLoc, noLoc, startPos) import Control.Exception (SomeException) import Language.C.Quote.C import qualified Language.C.Quote.GCC as GCC import qualified Language.C.Syntax as C import qualified Language.C.Parser as P import MainCPP import Numeric (showHex) import GCC (gccTests) import Objc (objcTests, objcRegressionTests) import CUDA (cudaTests) import Text.PrettyPrint.Mainland import Text.PrettyPrint.Mainland.Class main :: IO () main = defaultMain tests tests :: [Test] tests = [ constantTests , constantAntiquotationsTests , cQuotationTests , cPatternAntiquotationTests , statementCommentTests , regressionTests , gccTests , objcTests , objcRegressionTests , cudaTests ] constantTests :: Test constantTests = testGroup "Constants" [ testCase "octal constant" test_octint , testCase "hex constant" test_hexint , testCase "unsigned hex constant" test_hexint_u , testCase "unsigned long hex constant" test_hexint_ul , testCase "unsigned long long hex constant hexint" test_hexint_ull ] where test_octint :: Assertion test_octint = [cexp|010|] @?= C.Const (C.IntConst "010" C.Signed 8 noLoc) noLoc test_hexint :: Assertion test_hexint = [cexp|0x10|] @?= C.Const (C.IntConst "0x10" C.Signed 16 noLoc) noLoc test_hexint_u :: Assertion test_hexint_u = [cexp|0x10U|] @?= C.Const (C.IntConst "0x10U" C.Unsigned 16 noLoc) noLoc test_hexint_ul :: Assertion test_hexint_ul = [cexp|0x10UL|] @?= C.Const (C.LongIntConst "0x10UL" C.Unsigned 16 noLoc) noLoc test_hexint_ull :: Assertion test_hexint_ull = [cexp|0x10ULL|] @?= C.Const (C.LongLongIntConst "0x10ULL" C.Unsigned 16 noLoc) noLoc constantAntiquotationsTests :: Test constantAntiquotationsTests = testGroup "Constant antiquotations" $ [ testCase "int antiquotes" test_int , testCase "hex Const antiquote" test_hexconst , testCase "unsigned hex Const antiquote" test_hexconst_u , testGroup "float antiquotes" floatConstTests , testCase "char antiquote" test_char , testCase "string antiquote" test_string , testGroup "misc char constants" charConstTests ] ++ testCase_test_int_hsexp where test_int :: Assertion test_int = [cexp|$int:one + $uint:one + $lint:one + $ulint:one + $llint:one + $ullint:one|] @?= [cexp|1 + 1U + 1L + 1UL + 1LL + 1ULL|] where one :: Integer one = 1 test_hexconst :: Assertion test_hexconst = [cexp|$const:(hexconst (10 :: Integer))|] @?= C.Const (C.IntConst "0xa" C.Signed 10 noLoc) noLoc where hexconst :: Integral a => a -> C.Const hexconst i = C.IntConst ("0x" ++ showHex x "") C.Signed x noLoc where x :: Integer x = fromIntegral i test_hexconst_u :: Assertion test_hexconst_u = [cexp|$const:(hexconst_u (10 :: Integer))|] @?= C.Const (C.IntConst "0xa" C.Unsigned 10 noLoc) noLoc where hexconst_u :: Integral a => a -> C.Const hexconst_u i = C.IntConst ("0x" ++ showHex x "") C.Unsigned x noLoc where x :: Integer x = fromIntegral i floatConstTests :: [Test] floatConstTests = [ testCase "float antiquotes" test_float , testCase "NaN" test_NaN , testCase "Infinity" test_infinity ] where test_float :: Assertion test_float = [cexp|$float:one + $double:one + $ldouble:one|] @?= [cexp|1.0F + 1.0 + 1.0L|] where one :: Fractional a => a one = 1 test_NaN :: Assertion test_NaN = showCompact [cexp|$double:nan|] @?= "NAN" where nan :: RealFloat a => a nan = acos 2 test_infinity :: Assertion test_infinity = showCompact [cexp|$double:inf|] @?= "INFINITY" where inf :: RealFloat a => a inf = 1/0 test_char :: Assertion test_char = [cexp|$char:a|] @?= [cexp|'a'|] where a = 'a' test_string :: Assertion test_string = [cexp|$string:hello|] @?= [cexp|"Hello, world\n"|] where hello = "Hello, world\n" charConstTests :: [Test] charConstTests = [ charConstTest '\0' "'\\0'" , charConstTest '\xfff' "'\\u0fff'" , charConstTest '\xfffff' "'\\U000fffff'" ] where charConstTest :: Char -> String -> Test charConstTest c s = testCase ("character constant " ++ show c) $ showCompact [cexp|$char:c|] @?= s cQuotationTests :: Test cQuotationTests = testGroup "C quotations" [ testCase "raw expression-level escape" test_escexp , testCase "raw statement-level escape" test_escstm , testCase "identifier antiquote" test_id , testCase "expression antiquote" test_exp , testCase "function antiquote" test_func , testCase "args antiquote" test_args , testCase "declaration antiquote" test_decl , testCase "struct declaration antiquote" test_sdecl , testCase "external declaration antiquote" test_edecl , testCase "enum antiquote" test_enum , testCase "statement antiquote" test_stm , testCase "parameter antiquote" test_param , testCase "type qualifier antiquote" test_tyqual , testCase "type qualifiers antiquote" test_tyquals , testCase "type antiquote" test_ty , testCase "initializer antiquote" test_init , testCase "initializers antiquote" test_inits , testCase "block items antiquote" test_item , testCase "qualifier with type antiquote 1" test_qual_antitype1 , testCase "qualifier with type antiquote 2" test_qual_antitype2 ] where test_id :: Assertion test_id = [cexp|$id:f($id:x, $id:y)|] @?= [cexp|f(x, y)|] where f :: String f = "f" x :: SrcLoc -> C.Id x = C.Id "x" y :: C.Id y = C.Id "y" noLoc test_escexp :: Assertion test_escexp = let rawstr = "a rather random string" in [cexp|$esc:rawstr|] @?= C.EscExp rawstr noLoc test_escstm :: Assertion test_escstm = let rawstr = "a rather random string" in [citems|$escstm:rawstr if (1) return;|] @?= [ C.BlockStm $ C.EscStm rawstr noLoc , C.BlockStm $ C.If (C.Const (C.IntConst "1" C.Signed 1 noLoc) noLoc) (C.Return Nothing noLoc) Nothing noLoc ] test_exp :: Assertion test_exp = [cexp|$exp:e1 + $exp:e2|] @?= [cexp|1 + 2|] where e1 = [cexp|1|] e2 = [cexp|2|] test_func :: Assertion test_func = [cunit|$func:f|] @?= [cunit|int add(int x) { return x + 10; }|] where f = add (10 :: Integer) add n = [cfun|int add(int x) { return x + $int:n; } |] test_args :: Assertion test_args = [cstm|f($exp:e1, $args:args, $exp:e2);|] @?= [cstm|f(1, 2, 3, 4);|] where e1 = [cexp|1|] e2 = [cexp|4|] args = [[cexp|2|], [cexp|3|]] test_decl :: Assertion test_decl = [cfun|int inc(int n) { $decl:d1; $decls:decls return n + 1; }|] @?= [cfun|int inc(int n) { int i; int j; char c = 'c'; return n + 1; }|] where d1 = [cdecl|int i;|] d2 = [cdecl|int j;|] d3 = [cdecl|char c = 'c';|] decls = [d2, d3] test_sdecl :: Assertion test_sdecl = [cty|struct foo { $sdecl:d1 $sdecls:decls }|] @?= [cty|struct foo { int i; int j; char c; }|] where d1 = [csdecl|int i;|] d2 = [csdecl|int j;|] d3 = [csdecl|char c;|] decls = [d2, d3] test_edecl :: Assertion test_edecl = [cunit|$edecl:d1 $edecls:decls|] @?= [cunit|int i; int j; char c = 'c';|] where d1 = [cedecl|int i;|] d2 = [cedecl|int j;|] d3 = [cedecl|char c = 'c';|] decls = [d2, d3] test_enum :: Assertion test_enum = [cty|enum foo { $enum:enum1, $enums:enums }|] @?= [cty|enum foo { A = 0, B, C = 2 }|] where enum1 = [cenum|A = 0|] enum2 = [cenum|B|] enum3 = [cenum|C = 2|] enums = [enum2, enum3] test_stm :: Assertion test_stm = [cfun|int add(int x) { $stms:stms return x + 1; }|] @?= [cfun|int add(int x) { a = 1; b = 2; return x + 1; }|] where one :: Integer one = 1 stm1 = [cstm|a = $int:one;|] stm2 = [cstm|b = 2;|] stms = [stm1, stm2] test_param :: Assertion test_param = [cdecl|int f($param:ty1, $params:tys);|] @?= [cdecl|int f(char, int, float);|] where ty1 = [cparam|char|] ty2 = [cparam|int|] ty3 = [cparam|float|] tys = [ty2, ty3] test_tyqual :: Assertion test_tyqual = [cdecl|$tyqual:tyqual int i;|] @?= [cdecl|const int i;|] where tyqual = C.Tconst noLoc test_tyquals :: Assertion test_tyquals = [cdecl|$tyquals:tyquals int i;|] @?= [cdecl|const volatile int i;|] where tyquals = [ctyquals|const volatile|] test_ty :: Assertion test_ty = [cdecl|$ty:ty1 f(const $ty:ty2);|] @?= [cdecl|int f(const float);|] where ty1 = [cty|int|] ty2 = [cty|float|] test_init :: Assertion test_init = [cinit|{$init:initializer, .a = 10}|] @?= [cinit|{{.d = 1}, .a = 10}|] where initializer = [cinit|{.d = 1}|] test_inits :: Assertion test_inits = [cinit|{$inits:([initializer1, initializer2])}|] @?= [cinit|{{.d = 1},{.a = 10}}|] where initializer1 = [cinit|{.d = 1}|] initializer2 = [cinit|{.a = 10}|] test_item :: Assertion test_item = [cfun|int add(int x) { int y = 2; return x + y; }|] @?= [cfun|int add(int x) { $items:([item1, item2]) }|] where item1 = [citem|int y = 2;|] item2 = [citem|return x + y;|] test_qual_antitype1 :: Assertion test_qual_antitype1 = [cexp|(const $ty:tau) NULL|] @?= [cexp|(const int) NULL|] where tau = [cty|int|] test_qual_antitype2 :: Assertion test_qual_antitype2 = [cexp|(const $ty:tau *) NULL|] @?= [cexp|(const int*) NULL|] where tau = [cty|int|] cPatternAntiquotationTests :: Test cPatternAntiquotationTests = testGroup "C pattern antiquotations" [ testCase "arguments pattern antiquote" pat_args ] where pat_args :: Assertion pat_args = stms @?= [[cexp|2|], [cexp|3|]] where stms = case [cstm|f(1, 2, 3);|] of [cstm|f(1, $args:es);|] -> es _ -> [] statementCommentTests :: Test statementCommentTests = testGroup "Statement comments" [ testCase "lbrace comment" test_lbrace_comment , testCase "semi comment" test_semi_comment , testCase "c comment" test_c_comment , testCase "c++ comment" test_cxx_comment , testCase "antiquote comment" test_antiquote_comment , testCase "comment at end of statements quote" test_stms_end_comment , testCase "comment before antiquoted statements" test_block_stms_comment , testCase "comment at beginning of a block" test_issue_55 , testCase "comment inside cunit block" test_issue_76 ] where test_lbrace_comment :: Assertion test_lbrace_comment = [cstm|{ $comment:("/* Test 1 */") return x + y; }|] @?= [cstm|{/* Test 1 */ return x + y; }|] test_semi_comment :: Assertion test_semi_comment = [cstms|x = 1; $comment:("/* Test 1 */") return x + y;|] @?= [cstms|x = 1; /* Test 1 */ return x + y;|] assign_a_equals_one = C.Exp (Just $ C.Assign (C.Var (C.Id "a" noLoc) noLoc) C.JustAssign (C.Const (C.IntConst "1" C.Signed 1 noLoc) noLoc) noLoc) noLoc test_c_comment = [cstms| a = 1; /* c style comment */ |] @?= [ assign_a_equals_one , C.Comment "/* c style comment */" (C.Exp Nothing noLoc) noLoc ] test_cxx_comment = [cstms| a = 1; // c++ style comment |] @?= [ assign_a_equals_one , C.Comment "// c++ style comment" (C.Exp Nothing noLoc) noLoc ] test_antiquote_comment = [cstms| $comment:("/* antiquote comment */") |] @?= [ C.Comment "/* antiquote comment */" (C.Exp Nothing noLoc) noLoc ] test_stms_end_comment :: Assertion test_stms_end_comment = [cstms|x = 1; return x + y; $comment:("// Test")|] @?= [cstms|x = 1; return x + y; // Test|] test_block_stms_comment :: Assertion test_block_stms_comment = [cstm|{ int a; $decl:decl; /* Test */ $stms:stms }|] @?= [cstm|{ int a; int b; a = 1; b = 2;}|] where decl = [cdecl|int b;|] stm1 = [cstm|a = 1;|] stm2 = [cstm|b = 2;|] stms = [stm1, stm2] test_issue_55 :: Assertion test_issue_55 = [cunit|int f(int x) { // Breaking comment. int y; return x; }|] @?= [cunit|int f(int x) { $comment:("// Breaking comment.") int y; return x; }|] test_issue_76 :: Assertion test_issue_76 = [cunit| $edecl:d1 /* AAA */ $edecl:d2 struct A { int foo; }; /* BBB */ struct B { int bar; }; |] @?= [cunit| int i; /* AAA */ int j; struct A { int foo; }; $comment:(" BBB ") struct B { int bar; }; |] where d1 = [cedecl|int i;|] d2 = [cedecl|int j;|] regressionTests :: Test regressionTests = testGroup "Regressions" [ issue81 , issue76 , issue68 , issue64 , testCase "pragmas" test_pragmas , issue48 , testCase "Issue #44" issue44 , issue43 ] where test_pragmas :: Assertion test_pragmas = [cstms| #pragma omp sections { #pragma omp section a = 1; } |] @?= [ C.Pragma "omp sections" noLoc , C.Block [ C.BlockStm (C.Pragma "omp section" noLoc) , C.BlockStm (C.Exp (Just $ C.Assign (C.Var (C.Id "a" noLoc) noLoc) C.JustAssign (C.Const (C.IntConst "1" C.Signed 1 noLoc) noLoc) noLoc) noLoc) ] noLoc ] issue81 :: Test issue81 = testCase "Issue #81"$ showCompact [cstm|if (x > 1) { /* comment */ if (x > 2) x++; }|] @?= "if (x > 1) { /* comment */ if (x > 2) x++; }" issue76 :: Test issue76 = testCase "Issue #76" $ [cunit| /* AAA */ struct A { int foo; }; /* BBB */ struct B { int bar; }; |] @?= [cunit| /* AAA */ struct A { int foo; }; $comment:(" BBB ") struct B { int bar; }; |] issue68 :: Test issue68 = testCase "Issue #68"$ showCompact [cstm|if (!initialized) { $stms:init_stms }|] @?= "if (!initialized) { return; }" where init_stms :: [C.Stm] init_stms = [[cstm|return;|]] issue64 :: Test issue64 = testGroup "Issue #64" [ testCase "-($int:i)" test_issue64_1 , testCase "--($int:i)" test_issue64_2 ] where i :: Int i = -42 test_issue64_1 :: Assertion test_issue64_1 = pretty 80 (ppr [cexp|-($int:i)|]) @?= "-(-42)" test_issue64_2 :: Assertion test_issue64_2 = pretty 80 (ppr [cexp|--$int:i|]) @?= "--(-42)" issue48 :: Test issue48 = testGroup "Issue #48" [ testCase "-(-42)" test_issue48_1 , testCase "--(-42)" test_issue48_2 , testCase "-(--42)" test_issue48_3 , testCase "+(+42)" test_issue48_4 , testCase "++(+42)" test_issue48_5 , testCase "+(++42)" test_issue48_6 ] where test_issue48_1 :: Assertion test_issue48_1 = pretty 80 (ppr [cexp|-(-42)|]) @?= "-(-42)" test_issue48_2 :: Assertion test_issue48_2 = pretty 80 (ppr [cexp|--(-42)|]) @?= "--(-42)" test_issue48_3 :: Assertion test_issue48_3 = pretty 80 (ppr [cexp|-(--42)|]) @?= "-(--42)" test_issue48_4 :: Assertion test_issue48_4 = pretty 80 (ppr [cexp|+(+42)|]) @?= "+(+42)" test_issue48_5 :: Assertion test_issue48_5 = pretty 80 (ppr [cexp|++(+42)|]) @?= "++(+42)" test_issue48_6 :: Assertion test_issue48_6 = pretty 80 (ppr [cexp|+(++42)|]) @?= "+(++42)" issue44 :: Assertion issue44 = case parseDecl "$ty:something c;" of Left err -> fail (show err) Right grp -> (pretty 80 . ppr) grp @?= "$ty:something c" where parseDecl :: String -> Either SomeException C.InitGroup parseDecl s = P.parse [C.Antiquotation] [] P.parseDecl (B.pack s) (Just (startPos "")) issue43 :: Test issue43 = testGroup "Issue #43" [ testCase "float _Complex" test_issue43_1 , testCase "long double _Complex" test_issue43_2 , testCase "long _Complex double" test_issue43_3 , testCase "_Imaginary long double" test_issue43_4 ] where test_issue43_1 :: Assertion test_issue43_1 = [cty|float _Complex|] @?= C.Type (C.DeclSpec [] [] (C.Tfloat_Complex noLoc) noLoc) (C.DeclRoot noLoc) noLoc test_issue43_2 :: Assertion test_issue43_2 = [cty|long double _Complex|] @?= C.Type (C.DeclSpec [] [] (C.Tlong_double_Complex noLoc) noLoc) (C.DeclRoot noLoc) noLoc test_issue43_3 :: Assertion test_issue43_3 = [cty|long _Complex double|] @?= C.Type (C.DeclSpec [] [] (C.Tlong_double_Complex noLoc) noLoc) (C.DeclRoot noLoc) noLoc test_issue43_4 :: Assertion test_issue43_4 = [cty|_Imaginary long double|] @?= C.Type (C.DeclSpec [] [] (C.Tlong_double_Imaginary noLoc) noLoc) (C.DeclRoot noLoc) noLoc -- | Pretty-print a value on single line. showCompact :: Pretty a => a -> String showCompact = map space2space . flip displayS "" . renderCompact . ppr where space2space :: Char -> Char space2space c | isSpace c = ' ' | otherwise = c language-c-quote-0.13.0.2/tests/unit/MainCPP.hs0000644000000000000000000000136307346545000017171 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE QuasiQuotes #-} -- This module is needed because it's not possible to turn on CPP in Main.hs. -- We need CPP because this test case doesn't work without FULL_HASKELL_ANTIQUOTES -- turned on. (The simpler Haskell parser doesn't support infix operators.) module MainCPP where import Test.Framework (Test) import Test.Framework.Providers.HUnit import Test.HUnit (Assertion, (@?=)) import Language.C.Quote.C testCase_test_int_hsexp :: [Test] testCase_test_int_hsexp = #ifdef FULL_HASKELL_ANTIQUOTES [testCase "unsigned long antiquote of Haskell expression" test_int_hsexp] where test_int_hsexp :: Assertion test_int_hsexp = [cexp|$ulint:(13 - 2*5 :: Integer)|] @?= [cexp|3UL|] #else [] #endif language-c-quote-0.13.0.2/tests/unit/Objc.hs0000644000000000000000000001231507346545000016616 0ustar0000000000000000{-# LANGUAGE QuasiQuotes #-} module Objc ( objcTests, objcRegressionTests ) where import Test.Framework import Test.Framework.Providers.HUnit import Test.HUnit (Assertion, (@?=)) import Language.C.Quote.ObjC objcTests :: Test objcTests = testGroup "Objective-C" [ testCase "Objective-C params" objcProp , testCase "Objective-C property" objcDict , testCase "Objective-C method parameters" objcParam , testCase "Objective-C method definition" objcMethodDefinition , testCase "Objective-C classmethod" objcArgumentCls , testCase "Objective-C argument" objcArgument , testCase "Objective-C arguments" objcArguments , testCase "Objective-C varargument" objcVarArgument , testCase "Objective-C literals" objcLits ] where objcDict :: Assertion objcDict = [cexp| @{$dictelems:(elems [("a","b"),("c", "d")])} |] @?= [cexp| @{@"a" : @"b",@"c": @"d"}|] where elems = map (\(k,v) -> [objcdictelem|$exp:(objcLit k) : $exp:(objcLit v)|] ) objcProp :: Assertion objcProp = [cedecl| @interface Foo - (void) foo; $prop:propdec1 $props:propdec2 $prop:propdec3 @end |] @?= [cedecl| @interface Foo - (void) foo; @property (nonatomic, retain) int i; @property (nonatomic, retain) float j; @property (nonatomic, retain) char k; @property (nonatomic) double l; @end |] where propdec n typ = [objcprop|@property ($propattrs:r) $ty:typ $id:n;|] propdec' n typ = [objcprop|@property ($propattr:p) $ty:typ $id:n;|] p = [objcpropattr|nonatomic|] q = [objcpropattr|retain|] r = [p,q] propdec1 = propdec "i" [cty|int|] propdec2 = map (\(n,t) -> propdec n t) [("j", [cty|float|]), ("k", [cty|char|])] propdec3 = propdec' "l" [cty|double|] objcParam :: Assertion objcParam = [cedecl| @interface Foo - (void) $methparams:paramNew ; $methproto:val ; @end |] @?= [cedecl| @interface Foo - (void) foo:(int)str fo:(int)str1; + (int) test1:(int)str2; @end |] where paramNew1 = [objcmethparam|$id:("foo"):(int)str |] paramNew2 = [objcmethparam|fo:(int)str1 |] paramNew3 = [objcmethparam|test1:(int)str2 |] paramNew = [paramNew1, paramNew2] val = [objcmethproto|+ (int) $methparam:paramNew3|] objcMethodDefinition :: Assertion objcMethodDefinition = [cedecl| @implementation fooclass $methdefs:(val) $methdef:(val3) @end |] @?= [cedecl| @implementation fooclass + (int) test1:(int)foo { } - (char) test2:(char)bar { } + (float) test3:(double)baz { } @end |] where val3 = [objcmethdef|+ (float) $methparam:paramNew5 {} |] paramNew5 = [objcmethparam|test3:(double)baz |] val2 = [objcmethdef|+ (int) $methparam:paramNew3 {} |] paramNew3 = [objcmethparam|test1:(int)foo |] val1 = [objcmethdef|- (char) $methparam:paramNew4 {} |] paramNew4 = [objcmethparam|test2:(char)bar |] val = [val2, val1] objcArgumentCls :: Assertion objcArgumentCls = [citem|[somename test];|] @?= [citem|[$recv:(k) $id:("test")];|] where k = [objcmethrecv|somename|] objcArgument :: Assertion objcArgument = [citem|[$recv:(k) $kwarg:(p)];|] @?= [citem|[somename doSome:@"string"];|] where k = [objcmethrecv|somename|] p = [objcarg|doSome:@"string"|] objcArguments :: Assertion objcArguments = [citem|[$recv:(k) $kwargs:(r)];|] @?= [citem|[somename doSome:@"string" doSomeMore:@"moreStrings"];|] where k = [objcmethrecv|somename|] p = [objcarg|doSome:@"string"|] q = [objcarg|doSomeMore:@"moreStrings"|] r = [p,q] objcVarArgument :: Assertion objcVarArgument = [citem|[$recv:(k) $kwarg:(r) $args:(p)];|] @?= [citem|[NSString stringWithFormat:@"A string: %@, a float: %1.2f", @"string", 31415.9265];|] where k = [objcmethrecv|NSString|] r = [objcarg|stringWithFormat:@"A string: %@, a float: %1.2f"|] p = [a, b] a = [cexp|@"string"|] b = [cexp|31415.9265|] objcLits :: Assertion objcLits = [cexp|@[$(objcLit "foo"), $(objcLit True), $(objcLit False), $(objcLit 'a'), nil]|] @?= [cexp|@[@"foo", @YES, @NO, @'a', nil]|] objcRegressionTests :: Test objcRegressionTests = testGroup "Objective-C Regressions" [ testCase "Issue #51" issue51 ] where issue51 :: Assertion issue51 = [cunit| @interface $id:prefixedClassName : NSObject $ifdecls:ifaceDecls @end |] @?= [cunit| @interface dummyClass : NSObject - (void) foo:(int)str fo:(int)str1; + (int) test1:(int)str2; @end |] where prefixedClassName :: String prefixedClassName = "dummyClass" ifaceDecls = [objcifdecls| - (void) foo:(int)str fo:(int)str1; + (int) test1:(int)str2; |]