[Git][ghc/ghc][wip/az/ghc-cpp] 2 commits: Starting on expression parser.
Alan Zimmerman (@alanz)
gitlab at gitlab.haskell.org
Wed Oct 25 22:09:37 UTC 2023
Alan Zimmerman pushed to branch wip/az/ghc-cpp at Glasgow Haskell Compiler / GHC
Commits:
df453303 by Alan Zimmerman at 2023-10-05T23:03:45+01:00
Starting on expression parser.
But it hangs. Time for Text.Parsec.Expr
- - - - -
01f6c1eb by Alan Zimmerman at 2023-10-25T23:08:32+01:00
Start integrating the ghc-cpp work
>From https://github.com/alanz/ghc-cpp
- - - - -
13 changed files:
- + utils/check-cpp/.gitignore
- + utils/check-cpp/Eval.hs
- + utils/check-cpp/Example1.hs
- + utils/check-cpp/Example2.hs
- + utils/check-cpp/Lexer.x
- + utils/check-cpp/Macro.hs
- utils/check-cpp/Main.hs
- utils/check-cpp/Parse.hs
- + utils/check-cpp/ParseOld.hs
- + utils/check-cpp/ParserM.hs
- utils/check-cpp/PreProcess.hs
- + utils/check-cpp/README.md
- + utils/check-cpp/Types.hs
Changes:
=====================================
utils/check-cpp/.gitignore
=====================================
@@ -0,0 +1 @@
+Lexer.hs
=====================================
utils/check-cpp/Eval.hs
=====================================
@@ -0,0 +1,38 @@
+module Eval where
+
+import Parse
+
+-- ---------------------------------------------------------------------
+
+eval :: Expr -> Int
+eval (Parens e) = eval e
+eval (Var v) = error $ "need to look up :" ++ v
+eval (IntVal i) = i
+eval (Plus e1 e2) = (eval e1) + (eval e2)
+eval (Times e1 e2) = (eval e1) * (eval e2)
+eval (BinOp op e1 e2) = evalOp op (eval e1) (eval e2)
+
+evalOp :: Op -> Int -> Int -> Int
+evalOp LogicalOr e1 e2 = fromBool $ (toBool e1) || (toBool e2)
+evalOp LogicalAnd e1 e2 = fromBool $ (toBool e1) || (toBool e2)
+evalOp CmpEqual e1 e2 = fromBool $ e1 == e2
+evalOp CmpGt e1 e2 = fromBool $ e1 > e2
+evalOp CmpGtE e1 e2 = fromBool $ e1 >= e2
+evalOp CmpLt e1 e2 = fromBool $ e1 < e2
+evalOp CmpLtE e1 e2 = fromBool $ e1 <= e2
+
+toBool :: Int -> Bool
+toBool 0 = False
+toBool _ = True
+
+fromBool :: Bool -> Int
+fromBool False = 0
+fromBool True = 1
+
+-- ---------------------------------------------------------------------
+
+v0 :: Int
+v0 = eval (Plus (IntVal 1) (IntVal 3))
+
+v1 :: Int
+v1 = eval (BinOp CmpGt (IntVal 4) (IntVal 3))
=====================================
utils/check-cpp/Example1.hs
=====================================
@@ -0,0 +1,15 @@
+{-# LANGUAGE GhcCPP #-}
+module Example1 where
+
+y = 3
+
+#define FOO
+
+x =
+#ifndef FOO
+ "hello"
+#else
+ "bye now"
+#endif
+
+foo = putStrLn x
=====================================
utils/check-cpp/Example2.hs
=====================================
@@ -0,0 +1,19 @@
+{-# LANGUAGE GhcCPP #-}
+module Example2 where
+
+/* package ghc-exactprint-1.7.0.1 */
+#ifndef VERSION_ghc_exactprint
+#define VERSION_ghc_exactprint "1.7.0.1"
+#endif /* VERSION_ghc_exactprint */
+-- #ifndef MIN_VERSION_ghc_exactprint
+-- #define MIN_VERSION_ghc_exactprint(major1,major2,minor) (\
+-- (major1) < 1 || \
+-- (major1) == 1 && (major2) < 7 || \
+-- (major1) == 1 && (major2) == 7 && (minor) <= 0)
+-- #endif /* MIN_VERSION_ghc_exactprint */
+
+#ifdef VERSION_ghc_exactprint
+x = "got version"
+#else
+x = "no version"
+#endif
=====================================
utils/check-cpp/Lexer.x
=====================================
@@ -0,0 +1,129 @@
+{
+module Lexer (lex_tok, lexCppTokenStream) where
+
+import ParserM (
+ St, init_pos,
+ ParserM (..), Action, mkTv, Token(..), start_code,
+ setStartCode,
+ show_pos, position,
+ AlexInput(..), alexGetByte)
+import qualified ParserM as ParserM (input)
+import Control.Monad
+
+-- The lexer is based on
+-- https://timsong-cpp.github.io/cppwp/n4140/lex.pptoken
+}
+
+words :-
+
+ <0> $white+ ;
+---------------------------------------
+ <0> "{" { mkTv TOpenBrace }
+ <0> "}" { mkTv TCloseBrace }
+ <0> "[" { mkTv TOpenBracket }
+ <0> "]" { mkTv TCloseBracket }
+ <0> "#" { mkTv THash }
+ <0> "##" { mkTv THashHash }
+ <0> "(" { mkTv TOpenParen }
+ <0> ")" { mkTv TCloseParen }
+ <0> "<:" { mkTv TLtColon }
+ <0> ":>" { mkTv TColonGt}
+ <0> "<%" { mkTv TLtPercent }
+ <0> "%>" { mkTv TPercentGt }
+ <0> "%:" { mkTv TPercentColon }
+ <0> "%:%:" { mkTv TPercentColonTwice }
+ <0> ";" { mkTv TSemi }
+ <0> ":" { mkTv TColon }
+ <0> "..." { mkTv TDotDotDot }
+ <0> "new" { mkTv TNew }
+ <0> "delete" { mkTv TDelete }
+ <0> "?" { mkTv TQuestion }
+ <0> "::" { mkTv TColonColon}
+ <0> "." { mkTv TDot }
+ <0> ".*" { mkTv TDotStar }
+ <0> "+" { mkTv TPlus }
+ <0> "-" { mkTv TMinus }
+ <0> "*" { mkTv TStar }
+ <0> "/" { mkTv TSlash }
+ <0> "%" { mkTv TPercent }
+ <0> "^" { mkTv TUpArrow }
+ <0> "&" { mkTv TAmpersand }
+ <0> "|" { mkTv TPipe }
+ <0> "~" { mkTv TTilde }
+ <0> "!" { mkTv TExclamation }
+ <0> "=" { mkTv TEqual }
+ <0> "<" { mkTv TOpenAngle }
+ <0> ">" { mkTv TCloseAngle }
+ <0> "+=" { mkTv TPlusEqual }
+ <0> "-=" { mkTv TMinusEqual }
+ <0> "*=" { mkTv TStarEqual }
+ <0> "/=" { mkTv TSlashEqual }
+ <0> "%=" { mkTv TPercentEqual }
+ <0> "^=" { mkTv TUpEqual }
+ <0> "&=" { mkTv TAmpersandEqual }
+ <0> "|=" { mkTv TPipeEqual }
+ <0> "<<" { mkTv TLtLt }
+ <0> ">>" { mkTv TGtGt }
+ <0> ">>=" { mkTv TGtGtEqual }
+ <0> "<<=" { mkTv TLtLtEqual }
+ <0> "==" { mkTv TEqualEqual }
+ <0> "!=" { mkTv TExclaimEqual }
+ <0> "<=" { mkTv TLtEqual }
+ <0> ">=" { mkTv TGtEqual }
+ <0> "&&" { mkTv TAmpersandTwice }
+ <0> "||" { mkTv TPipePipe }
+ <0> "++" { mkTv TPlusPlus }
+ <0> "--" { mkTv TMinusMinus }
+ <0> "," { mkTv TComma }
+ <0> "->*" { mkTv TMinusGtStar }
+ <0> "->" { mkTv TMinusGt }
+ <0> "and" { mkTv TAnd }
+ <0> "and_eq" { mkTv TAndEq }
+ <0> "bitand" { mkTv TBitand }
+ <0> "bitor" { mkTv TBitor }
+ <0> "compl" { mkTv TCompl }
+ <0> "not" { mkTv TNot }
+ <0> "not_eq" { mkTv TNotEq }
+ <0> "or" { mkTv TOr }
+ <0> "or_eq" { mkTv TOrEq }
+ <0> "xor" { mkTv TXor }
+ <0> "xor_eq" { mkTv TXorEq }
+----------------------------------------
+ <0> [a-z][a-zA-Z0-9\#_]* { mkTv TLowerName }
+ <0> [A-Z][a-zA-Z0-9\#_]* { mkTv TUpperName }
+ <0> \-? [0-9][0-9]* { mkTv TInteger }
+ <0> \" [^\"]* \" { mkTv (TString . tail . init) }
+ <0> () { begin other }
+
+ <other> .+ { \i -> do {setStartCode 0;
+ mkTv TOther i} }
+
+{
+
+begin :: Int -> Action
+begin sc _str =
+ do setStartCode sc
+ get_tok
+
+get_tok :: ParserM Token
+get_tok = ParserM $ \i st ->
+ case alexScan i (start_code st) of
+ AlexEOF -> Right (i, st, TEOF "")
+ AlexError _ -> Left ("Lexical error at " ++ show_pos (position i))
+ AlexSkip i' _ -> case get_tok of
+ ParserM f -> f i' st
+ AlexToken i' l a -> case a $ take l $ ParserM.input i of
+ ParserM f -> f i' st
+
+lex_tok :: (Token -> ParserM a) -> ParserM a
+lex_tok cont = get_tok >>= cont
+
+lexCppTokenStream :: String -> St -> Either String (AlexInput, St, [Token])
+lexCppTokenStream s = unParserM go (AlexInput init_pos [] s)
+ where
+ go = do
+ ltok <- lex_tok return
+ case ltok of
+ TEOF _ -> return []
+ _ -> liftM (ltok:) go
+}
=====================================
utils/check-cpp/Macro.hs
=====================================
@@ -0,0 +1,121 @@
+module Macro where
+
+-- From https://gcc.gnu.org/onlinedocs/cpp/Macros.html
+
+{-
+
+A macro is a fragment of code which has been given a name. Whenever
+the name is used, it is replaced by the contents of the macro. There
+are two kinds of macros. They differ mostly in what they look like
+when they are used. Object-like macros resemble data objects when
+used, function-like macros resemble function calls.
+
+... the preprocessor operator `defined` can never be defined as a macro
+
+If the expansion of a macro contains its own name, either directly or
+via intermediate macros, it is not expanded again when the expansion
+is examined for more macros. See
+https://gcc.gnu.org/onlinedocs/cpp/Self-Referential-Macros.html for
+details
+
+-}
+
+-- TODO: Parse tokens with original locations in them.
+
+import qualified Data.Map as Map
+import Data.Maybe
+
+import Eval
+import Lexer
+import Parse
+import ParserM
+import Types
+
+-- ---------------------------------------------------------------------
+
+process :: PpState -> Input -> (PpState, Output)
+process s str = (s0, o)
+ where
+ o = case regularParse cppDirective str of
+ Left _ -> undefined
+ Right r -> r
+ s0 = case o of
+ CppDefine name toks -> define s name toks
+ CppInclude _ -> undefined
+ CppIfdef name -> ifdef s name
+ CppIf toks -> cppIf s toks
+ CppIfndef name -> ifndef s name
+ CppElse -> undefined
+ CppEndif -> undefined
+
+-- ---------------------------------------------------------------------
+
+define :: PpState -> String -> MacroDef -> PpState
+define s name toks = s{pp_defines = Map.insert (MacroName name Nothing) toks (pp_defines s)}
+
+ifdef :: PpState -> String -> PpState
+ifdef s name =
+ case Map.lookup (MacroName name Nothing) (pp_defines s) of
+ Just _ -> s{pp_accepting = True}
+ _ -> s{pp_accepting = False}
+
+ifndef :: PpState -> String -> PpState
+ifndef s name =
+ case Map.lookup (MacroName name Nothing) (pp_defines s) of
+ Just _ -> s{pp_accepting = False}
+ _ -> s{pp_accepting = True}
+
+cppIf :: PpState -> [String] -> PpState
+cppIf s toks = r
+ where
+ expanded = expand s (unwords toks)
+ -- toks0 = cppLex expanded
+ -- r = error (show toks0)
+ v = case regularParse plusTimesExpr expanded of
+ Left err -> error $ show err
+ Right tree -> eval tree
+ -- We evaluate to an Int, which we convert to a bool
+ r = s{pp_accepting = toBool v}
+
+-- ---------------------------------------------------------------------
+
+cppLex :: String -> Either String [Token]
+cppLex s = case lexCppTokenStream s init_state of
+ Left err -> Left err
+ Right (_inp, _st, toks) -> Right toks
+
+-- ---------------------------------------------------------------------
+
+expand :: PpState -> String -> String
+expand s str = expanded
+ where
+ -- TODO: repeat until re-expand or fixpoint
+ toks = case cppLex str of
+ Left err -> error err
+ Right tks -> tks
+ expanded = unwords $ concatMap (expandOne s) toks
+
+expandOne :: PpState -> Token -> [String]
+expandOne s tok = r
+ where
+ -- TODO: protect against looking up `define`
+ r =
+ fromMaybe
+ [t_str tok]
+ (Map.lookup (MacroName (t_str tok) Nothing) (pp_defines s))
+
+-- ---------------------------------------------------------------------
+
+m0 :: (PpState, Output)
+m0 = do
+ let (s0, _) = process initPpState "#define FOO 3"
+ let (s1, _) = process s0 "#ifdef FOO"
+ process s1 "# if FOO == 4"
+
+-- ---------------------------------------------------------------------
+
+m1 :: Either String [Token]
+m1 = cppLex "`"
+
+m2 :: Either String [Token]
+m2 = cppLex "hello(5)"
=====================================
utils/check-cpp/Main.hs
=====================================
@@ -26,7 +26,9 @@ import GHC.Utils.Error
import GHC.Utils.Outputable
import qualified Text.Parsec as Parsec
+-- import ParseOld
import Parse
+import Types
import ParseSimulate
import PreProcess
@@ -58,8 +60,8 @@ parseString libdir includes str = ghcWrapper libdir $ do
return $ strGetToks includes pflags "fake_test_file.hs" str
strGetToks :: Includes -> Lexer.ParserOpts -> FilePath -> String -> [Located Token]
--- strGetToks includes popts filename str = reverse $ lexAll pstate
-strGetToks includes popts filename str = reverse $ lexAll (trace ("pstate=" ++ show initState) pstate)
+strGetToks includes popts filename str = reverse $ lexAll pstate
+-- strGetToks includes popts filename str = reverse $ lexAll (trace ("pstate=" ++ show initState) pstate)
where
includeMap = Map.fromList $ map (\(k, v) -> (k, stringToStringBuffer (intercalate "\n" v))) includes
initState = initPpState{pp_includes = includeMap}
@@ -69,7 +71,8 @@ strGetToks includes popts filename str = reverse $ lexAll (trace ("pstate=" ++ s
-- cpp_enabled = Lexer.GhcCppBit `Lexer.xtest` Lexer.pExtsBitmap popts
lexAll state = case unP (ppLexerDbg True return) state of
- POk _ t@(L _ ITeof) -> [t]
+ -- POk _ t@(L _ ITeof) -> [t]
+ POk s t@(L _ ITeof) -> trace ("lexall end:s=" ++ show (Lexer.pp s)) [t]
POk state' t -> t : lexAll state'
-- (trace ("lexAll: " ++ show (unLoc t)) state')
PFailed pst -> error $ "failed" ++ showErrorMessages (GHC.GhcPsMessage <$> GHC.getPsErrorMessages pst)
@@ -299,3 +302,14 @@ testIncludes =
, ["#define FOO"]
)
]
+
+t11 :: IO ()
+t11 = do
+ doTest
+ [ "#define FOO 4"
+ , "#if FOO > 3"
+ , "x = 1"
+ , "#else"
+ , "x = 5"
+ , "#endif"
+ ]
=====================================
utils/check-cpp/Parse.hs
=====================================
@@ -1,40 +1,82 @@
module Parse where
import Data.Char
+
+import Control.Monad (void)
+import Data.Functor.Identity
+import Debug.Trace
import GHC.Parser.Errors.Ppr ()
+import Text.Parsec
import qualified Text.Parsec as Parsec
import Text.Parsec.Char as PS
import Text.Parsec.Combinator as PS
-import Text.Parsec.Prim as PS
-import Text.Parsec.String (Parser)
+import qualified Text.Parsec.Expr as E
+import Text.Parsec.Language (emptyDef)
+import Text.Parsec.Prim as PS hiding (token)
+import qualified Text.Parsec.Token as P
+
+import Types
+
+-- =====================================================================
+-- First parse to CPP tokens, using a C++-like language spec
+-- https://gcc.gnu.org/onlinedocs/cpp/Tokenization.html
--- import Debug.Trace
+lexer :: P.TokenParser ()
+lexer = P.makeTokenParser exprDef
+exprDef :: P.LanguageDef st
+exprDef =
+ emptyDef
+ { P.commentStart = "/*"
+ , P.commentEnd = "*/"
+ , P.commentLine = "//"
+ , P.nestedComments = False
+ , P.identStart = letter <|> char '_'
+ , P.identLetter = alphaNum <|> oneOf "_'"
+ , P.opStart = P.opLetter exprDef
+ , P.opLetter = oneOf ":!#$%&*+./<=>?@\\^|-~"
+ , P.reservedOpNames = []
+ , P.reservedNames = []
+ , P.caseSensitive = True
+ }
+
+-- =====================================================================
-- ---------------------------------------------------------------------
+-- type CppParser = Parsec String PpState
type CppParser = Parsec String ()
-regularParse :: Parser a -> String -> Either Parsec.ParseError a
+parseDirective :: String -> Either Parsec.ParseError CppDirective
+parseDirective = regularParse cppDirective
+
+regularParse :: CppParser a -> String -> Either Parsec.ParseError a
+-- regularParse :: CppParser a -> String -> Either Parsec.ParseError (PpState, a)
regularParse p = PS.parse p ""
+-- regularParse :: CppParser a -> String -> Either Parsec.ParseError a
+-- regularParse p str = do
+-- case parsePpState initPpState p str of
+-- Left e ->Left e
+-- Right (_,r) -> Right r
+
+-- parsePpState :: PpState -> Parsec String PpState a -> String -> Either ParseError (PpState, a)
+-- parsePpState s p = Parsec.runParser p' s "source"
+-- where
+-- p' = do
+-- r <- p
+-- s' <- Parsec.getState
+-- return (s', r)
+
-- TODO: delete this
cppDefinition :: CppParser (String, [String])
cppDefinition = do
_ <- PS.char '#'
_ <- whiteSpace
- _ <- lexeme (PS.string "define")
+ eToken "define"
name <- cppToken
definition <- cppTokens
return (name, definition)
-data CppDirective
- = CppInclude String
- | CppDefine String [String]
- | CppIfdef String
- | CppIfndef String
- | CppElse
- | CppEndif
- deriving (Show, Eq)
cppDirective :: CppParser CppDirective
cppDirective = do
@@ -44,10 +86,10 @@ cppDirective = do
[ cppKw "define" >> cmdDefinition
, try $ cppKw "include" >> cmdInclude
, try $ cppKw "ifdef" >> cmdIfdef
- , cppKw "ifndef" >> cmdIfndef
+ , try $ cppKw "ifndef" >> cmdIfndef
+ , try $ cppKw "if" >> cmdIf
, try $ cppKw "else" >> return CppElse
, cppKw "endif" >> return CppEndif
- -- , cppKw "if" CppIfKw
-- , cppKw "elif" CppElifKw
-- , cppKw "undef" CppUndefKw
-- , cppKw "error" CppErrorKw
@@ -63,23 +105,19 @@ cmdInclude = do
cmdDefinition :: CppParser CppDirective
cmdDefinition = do
name <- cppToken
- definition <- cppTokens
- return $ CppDefine name definition
+ CppDefine name <$> cppTokens
cmdIfdef :: CppParser CppDirective
-cmdIfdef = do
- name <- cppToken
- return $ CppIfdef name
+cmdIfdef = CppIfdef <$> cppToken
cmdIfndef :: CppParser CppDirective
-cmdIfndef = do
- name <- cppToken
- return $ CppIfndef name
+cmdIfndef = CppIfndef <$> cppToken
+
+cmdIf :: CppParser CppDirective
+cmdIf = CppIf <$> cppTokens
cppKw :: String -> CppParser ()
-cppKw kw = do
- _ <- lexeme (PS.string kw)
- return ()
+cppKw kw = void $ lexeme (PS.string kw)
cppComment :: CppParser ()
cppComment = do
@@ -89,106 +127,144 @@ cppComment = do
whiteSpace :: CppParser ()
whiteSpace = do
- _ <- PS.many (PS.choice [cppComment, PS.space >> return ()])
+ _ <- PS.many (PS.choice [cppComment, void PS.space])
return ()
lexeme :: CppParser a -> CppParser a
lexeme p = p <* whiteSpace
cppToken :: CppParser String
-cppToken = lexeme (PS.many1 (PS.satisfy (\c -> not (isSpace c))))
+cppToken = lexeme (PS.many1 (PS.satisfy (not . isSpace)))
cppTokens :: CppParser [String]
cppTokens = PS.many cppToken
+-- token :: String -> CppParser ()
+-- token str = do
+-- _ <- lexeme (PS.string str)
+-- return ()
+
-- ---------------------------------------------------------------------
--- import GHC.S.Types
-
--- parseS :: String -> Either ParseError S
--- parseS = parse expr ""
-
--- lexer :: P.TokenParser ()
--- lexer =
--- P.makeTokenParser
--- ( emptyDef
--- { P.reservedNames =
--- [ "define"
--- , "include"
--- , "undef"
--- , "error"
--- , "ifdef"
--- , "ifndef"
--- , "if"
--- , "elif"
--- , "else"
--- , "endif"
--- ]
--- }
--- )
-
--- slam :: Parser S
--- slam = P.parens lexer $ do
--- P.reserved lexer "lam"
--- ident <- P.identifier lexer
--- body <- expr
--- return (SLam (Atom ident) body)
-
--- slet :: Parser S
--- slet = P.parens lexer $ do
--- P.reserved lexer "let"
--- (ident, e1) <- P.parens lexer $ do
--- idnt <- P.identifier lexer
--- expr1 <- expr
--- return (idnt, expr1)
--- e2 <- expr
--- return (SLet (Atom ident) e1 e2)
-
--- sletrec :: Parser S
--- sletrec = P.parens lexer $ do
--- P.reserved lexer "letrec"
--- ls <- P.parens lexer $ many1 $ P.parens lexer $ do
--- idnt <- P.identifier lexer
--- expr1 <- expr
--- return (Atom idnt, expr1)
--- e2 <- expr
--- return (SLetRec ls e2)
-
--- scase :: Parser S
--- scase = P.parens lexer $ do
--- P.reserved lexer "case"
--- e <- expr
--- alt <- optionMaybe (P.identifier lexer)
--- alts <- P.parens lexer $ many1 $ P.parens lexer $ do
--- pat <- expr
--- ex <- expr
--- return (pat, ex)
--- case alt of
--- Just alt -> return (SCase (Atom alt) e alts)
--- Nothing -> return (SCase (Atom "_") e alts)
-
--- swild :: Parser S
--- swild = do
--- P.symbol lexer "_"
--- return SWild
-
--- sbinop :: Parser S
--- sbinop = P.parens lexer $ do
--- e1 <- expr
--- op <- P.operator lexer
--- e2 <- expr
--- return (SBinOp (Atom op) e1 e2)
-
--- expr :: Parser S
--- expr =
--- choice
--- [ try slam
--- , try sbinop
--- , try slet
--- , try sletrec
--- , try scase
--- , STuple <$> P.parens lexer (many expr)
--- , swild
--- , SAtom <$> (Atom <$> (P.identifier lexer))
--- , SString <$> P.stringLiteral lexer
--- , SInt <$> P.integer lexer
--- ]
+-- Expression language
+-- NOTE: need to take care of macro expansion while parsing. Or perhaps before?
+
+
+data Expr
+ = Parens Expr
+ | Var String
+ | IntVal Int
+ | Plus Expr Expr
+ | Times Expr Expr
+ | BinOp Op Expr Expr
+ deriving (Show)
+
+data Op
+ = LogicalOr
+ | LogicalAnd
+ | CmpEqual
+ | CmpGt
+ | CmpGtE
+ | CmpLt
+ | CmpLtE
+ deriving (Show)
+
+-- -------------------------------------
+
+plusTimesExpr :: CppParser Expr
+plusTimesExpr = E.buildExpressionParser eTable eTerm
+
+eTable :: [[E.Operator String () Data.Functor.Identity.Identity Expr]]
+eTable =
+ -- Via https://learn.microsoft.com/en-us/cpp/cpp/cpp-built-in-operators-precedence-and-associativity?view=msvc-170
+ [ [E.Infix (Times <$ symbol "*") E.AssocLeft]
+ , [E.Infix (Plus <$ symbol "+") E.AssocLeft]
+ ,
+ [ E.Infix (try $ BinOp CmpLtE <$ symbol "<=") E.AssocLeft
+ , E.Infix (try $ BinOp CmpGtE <$ symbol ">=") E.AssocLeft
+ , E.Infix (BinOp CmpLt <$ symbol "<") E.AssocLeft
+ , E.Infix (BinOp CmpGt <$ symbol ">") E.AssocLeft
+ ]
+ , [E.Infix (BinOp CmpEqual <$ symbol "==") E.AssocLeft]
+ , [E.Infix (BinOp LogicalAnd <$ symbol "&&") E.AssocLeft]
+ , [E.Infix (BinOp LogicalOr <$ symbol "||") E.AssocLeft]
+ ]
+
+eTerm :: CppParser Expr
+eTerm =
+ eVariable -- <|> pteNum
+ <|> pteParens
+ <|> eInteger
+
+pteParens :: CppParser Expr
+pteParens = Parens <$> between (symbol "(") (symbol ")") plusTimesExpr
+
+symbol :: String -> CppParser String
+symbol s = lexeme $ string s
+
+-- -------------------------------------
+
+eExpr :: CppParser Expr
+eExpr = choice [eParens, eBinOp, eVariable]
+
+eParens :: CppParser Expr
+eParens = P.parens lexer $ do
+ Parens <$> eExpr
+
+eBinOp :: CppParser Expr
+eBinOp = do
+ e1 <- eExpr
+ op <- eOp
+ -- _ <- cppToken
+ -- let op = Or
+ BinOp op e1 <$> eExpr
+
+eOp :: CppParser Op
+eOp = do
+ -- op <- P.operator lexer
+ op <- P.operator (trace "foo" lexer)
+ return $ trace ("op=" ++ show op) LogicalOr
+
+eVariable :: CppParser Expr
+eVariable = do
+ v <- P.identifier lexer
+ return $ Var v
+
+eToken :: String -> CppParser ()
+eToken = P.reserved lexer
+
+eInteger :: CppParser Expr
+eInteger = IntVal <$> integer
+
+integer :: CppParser Int
+integer = read <$> lexeme (many1 digit)
+
+-- ---------------------------------------------------------------------
+
+doATest :: String -> Either Parsec.ParseError CppDirective
+doATest str = regularParse cppDirective str
+
+t0 :: Either Parsec.ParseError CppDirective
+t0 = doATest "#define FOO(m1,m2,m) ((m1) < 1 || (m1) == 1 && (m2) < 7 || (m1) == 1 && (m2) == 7 && (m) <= 0)"
+
+t1 :: Either Parsec.ParseError Expr
+t1 = regularParse plusTimesExpr "(m < 1)"
+
+t2 :: Either Parsec.ParseError Expr
+t2 = regularParse plusTimesExpr "((m1) < 1 || (m1) == 1 && (m2) < 7 || (m1) == 1 && (m2) == 7 && (m) <= 0)"
+
+-- (Parens
+-- (BinOp LogicalOr
+-- (BinOp LogicalOr
+-- (BinOp CmpLt (Parens (Var "m1")) (IntVal 1))
+-- (BinOp LogicalAnd
+-- (BinOp CmpEqual (Parens (Var "m1")) (IntVal 1))
+-- (BinOp CmpLt (Parens (Var "m2")) (IntVal 7))))
+-- (BinOp LogicalAnd
+-- (BinOp LogicalAnd
+-- (BinOp CmpEqual (Parens (Var "m1")) (IntVal 1))
+-- (BinOp CmpEqual (Parens (Var "m2")) (IntVal 7)))
+-- (BinOp CmpLtE (Parens (Var "m")) (IntVal 0)))))
+
+
+t3 :: Either ParseError CppDirective
+t3 = regularParse cppDirective "# if FOO == 4"
=====================================
utils/check-cpp/ParseOld.hs
=====================================
@@ -0,0 +1,249 @@
+module ParseOld where
+
+import Data.Char
+
+import Data.Functor.Identity
+import GHC.Parser.Errors.Ppr ()
+import Text.Parsec
+import qualified Text.Parsec as Parsec
+import Text.Parsec.Char as PS
+import Text.Parsec.Combinator as PS
+import qualified Text.Parsec.Expr as E
+import Text.Parsec.Language (emptyDef)
+import Text.Parsec.Prim as PS hiding (token)
+import Text.Parsec.String
+
+-- import Text.Parsec.String (Parser)
+import qualified Text.Parsec.Token as P
+
+import Debug.Trace
+
+-- ---------------------------------------------------------------------
+
+type CppParser = Parsec String ()
+
+regularParse :: Parser a -> String -> Either Parsec.ParseError a
+regularParse p = PS.parse p ""
+
+-- TODO: delete this
+cppDefinition :: CppParser (String, [String])
+cppDefinition = do
+ _ <- PS.char '#'
+ _ <- whiteSpace
+ eToken "define"
+ name <- cppToken
+ definition <- cppTokens
+ return (name, definition)
+
+data CppDirective
+ = CppInclude String
+ | CppDefine String [String]
+ | CppIfdef String
+ | CppIfndef String
+ | CppElse
+ | CppEndif
+ deriving (Show, Eq)
+
+cppDirective :: CppParser CppDirective
+cppDirective = do
+ _ <- PS.char '#'
+ _ <- whiteSpace
+ choice
+ [ cppKw "define" >> cmdDefinition
+ , try $ cppKw "include" >> cmdInclude
+ , try $ cppKw "ifdef" >> cmdIfdef
+ , cppKw "ifndef" >> cmdIfndef
+ , try $ cppKw "else" >> return CppElse
+ , cppKw "endif" >> return CppEndif
+ -- , cppKw "if" CppIfKw
+ -- , cppKw "elif" CppElifKw
+ -- , cppKw "undef" CppUndefKw
+ -- , cppKw "error" CppErrorKw
+ ]
+
+cmdInclude :: CppParser CppDirective
+cmdInclude = do
+ _ <- string "\""
+ filename <- many1 (satisfy (\c -> not (isSpace c || c == '"')))
+ _ <- string "\""
+ return $ CppInclude filename
+
+cmdDefinition :: CppParser CppDirective
+cmdDefinition = do
+ name <- cppToken
+ definition <- cppTokens
+ return $ CppDefine name definition
+
+cmdIfdef :: CppParser CppDirective
+cmdIfdef = do
+ name <- cppToken
+ return $ CppIfdef name
+
+cmdIfndef :: CppParser CppDirective
+cmdIfndef = do
+ name <- cppToken
+ return $ CppIfndef name
+
+cppKw :: String -> CppParser ()
+cppKw kw = do
+ _ <- lexeme (PS.string kw)
+ return ()
+
+cppComment :: CppParser ()
+cppComment = do
+ _ <- PS.string "/*"
+ _ <- PS.manyTill PS.anyChar (PS.try (PS.string "*/"))
+ return ()
+
+whiteSpace :: CppParser ()
+whiteSpace = do
+ _ <- PS.many (PS.choice [cppComment, PS.space >> return ()])
+ return ()
+
+lexeme :: CppParser a -> CppParser a
+lexeme p = p <* whiteSpace
+
+cppToken :: CppParser String
+cppToken = lexeme (PS.many1 (PS.satisfy (\c -> not (isSpace c))))
+
+cppTokens :: CppParser [String]
+cppTokens = PS.many cppToken
+
+-- token :: String -> CppParser ()
+-- token str = do
+-- _ <- lexeme (PS.string str)
+-- return ()
+
+-- ---------------------------------------------------------------------
+-- Expression language
+-- NOTE: need to take care of macro expansion while parsing. Or perhaps before?
+
+lexer :: P.TokenParser ()
+lexer = P.makeTokenParser exprDef
+
+exprDef :: P.LanguageDef st
+exprDef =
+ emptyDef
+ { P.commentStart = "/*"
+ , P.commentEnd = "*/"
+ , P.commentLine = "//"
+ , P.nestedComments = False
+ , P.identStart = letter <|> char '_'
+ , P.identLetter = alphaNum <|> oneOf "_'"
+ , P.opStart = P.opLetter exprDef
+ , P.opLetter = oneOf ":!#$%&*+./<=>?@\\^|-~"
+ , P.reservedOpNames = []
+ , P.reservedNames = []
+ , P.caseSensitive = True
+ }
+
+data Expr
+ = Parens Expr
+ | Var String
+ | IntVal Int
+ | Plus Expr Expr
+ | Times Expr Expr
+ | BinOp Op Expr Expr
+ deriving (Show)
+
+data Op
+ = Or
+ | And
+ | CmpEqual
+ | CmpGt
+ | CmpGtE
+ | CmpLt
+ | CmpLtE
+ deriving (Show)
+
+-- -------------------------------------
+
+plusTimesExpr :: CppParser Expr
+plusTimesExpr = E.buildExpressionParser eTable eTerm
+
+eTable :: [[E.Operator String () Data.Functor.Identity.Identity Expr]]
+eTable =
+ [ [E.Infix (Times <$ symbol "*") E.AssocLeft]
+ , [E.Infix (Plus <$ symbol "+") E.AssocLeft]
+ , [E.Infix (BinOp CmpLt <$ symbol "<") E.AssocLeft]
+ ]
+
+eTerm :: CppParser Expr
+eTerm = eVariable -- <|> pteNum
+ <|> pteParens
+ <|> eInteger
+
+pteParens :: CppParser Expr
+pteParens = Parens <$> between (symbol "(") (symbol ")") plusTimesExpr
+
+symbol :: String -> CppParser String
+symbol s = lexeme $ string s
+
+-- expr = E.buildExpressionParser table term
+-- <?> "expression"
+
+-- term = parens expr
+-- <|> natural
+-- <?> "simple expression"
+
+-- table = [ [prefix "-" negate, prefix "+" id ]
+-- , [postfix "++" (+1)]
+-- , [binary "*" (*) AssocLeft, binary "/" (div) AssocLeft ]
+-- , [binary "+" (+) AssocLeft, binary "-" (-) AssocLeft ]
+-- ]
+
+-- binary name fun assoc = Infix (do{ reservedOp name; return fun }) assoc
+-- prefix name fun = Prefix (do{ reservedOp name; return fun })
+-- postfix name fun = Postfix (do{ reservedOp name; return fun })
+
+-- -------------------------------------
+
+eExpr :: CppParser Expr
+eExpr = choice [eParens, eBinOp, eVariable]
+
+eParens :: CppParser Expr
+eParens = P.parens lexer $ do
+ e <- eExpr
+ return $ Parens e
+
+eBinOp :: CppParser Expr
+eBinOp = do
+ e1 <- eExpr
+ op <- eOp
+ -- _ <- cppToken
+ -- let op = Or
+ e2 <- eExpr
+ return $ BinOp op e1 e2
+
+eOp :: CppParser Op
+eOp = do
+ -- op <- P.operator lexer
+ op <- P.operator (trace "foo" lexer)
+ return $ trace ("op=" ++ show op) Or
+
+eVariable :: CppParser Expr
+eVariable = do
+ v <- P.identifier lexer
+ return $ Var v
+
+eToken :: String -> CppParser ()
+eToken str = P.reserved lexer str
+
+eInteger :: Parser Expr
+eInteger = IntVal <$> integer
+
+integer :: Parser Int
+integer = read <$> lexeme (many1 digit)
+
+-- ---------------------------------------------------------------------
+
+doATest :: String -> Either Parsec.ParseError CppDirective
+doATest str =
+ regularParse cppDirective str
+
+t0 :: Either Parsec.ParseError CppDirective
+t0 = doATest "#define FOO(m1,m2,m) ((m1) < 1 || (m1) == 1 && (m2) < 7 || (m1) == 1 && (m2) == 7 && (m) <= 0)"
+
+t1 :: Either Parsec.ParseError Expr
+-- t1 = regularParse eExpr "(m < 1)"
+t1 = regularParse plusTimesExpr "(m < 1)"
=====================================
utils/check-cpp/ParserM.hs
=====================================
@@ -0,0 +1,254 @@
+{-# LANGUAGE BinaryLiterals #-}
+
+module ParserM (
+ -- Parser Monad
+ ParserM (..),
+ AlexInput (..),
+ run_parser,
+ -- Parser state
+ St,
+ init_state,
+ StartCode,
+ start_code,
+ setStartCode,
+ -- Tokens
+ Token (..),
+ -- Actions
+ Action,
+ andBegin,
+ mkT,
+ mkTv,
+ -- Positions
+ init_pos,
+ get_pos,
+ show_pos,
+ -- Input
+ alexGetByte,
+ alexInputPrevChar,
+ -- Other
+ happyError,
+) where
+
+import Control.Applicative
+
+import Control.Monad.Fail (MonadFail (..))
+import Prelude hiding (fail)
+
+import Control.Monad (ap, liftM)
+import Data.Bits (shiftR, (.&.), (.|.))
+import Data.Char (ord)
+import Data.Word (Word8)
+
+-- Parser Monad
+newtype ParserM a = ParserM {unParserM :: AlexInput -> St -> Either String (AlexInput, St, a)}
+
+-- newtype P a = P { unP :: PState -> ParseResult a }
+
+instance Functor ParserM where
+ fmap = liftM
+
+instance Applicative ParserM where
+ pure a = ParserM $ \i s -> Right (i, s, a)
+ (<*>) = ap
+
+instance Monad ParserM where
+ ParserM m >>= k = ParserM $ \i s -> case m i s of
+ Right (i', s', x) ->
+ case k x of
+ ParserM y -> y i' s'
+ Left err ->
+ Left err
+
+instance MonadFail ParserM where
+ fail err = ParserM $ \_ _ -> Left err
+
+run_parser :: ParserM a -> (String -> Either String a)
+run_parser (ParserM f) =
+ \s -> case f (AlexInput init_pos [] s) init_state of
+ Left es -> Left es
+ Right (_, _, x) -> Right x
+
+-- Parser state
+
+data St = St
+ { start_code :: !StartCode
+ , brace_depth :: !Int
+ }
+ deriving (Show)
+type StartCode = Int
+
+init_state :: St
+init_state =
+ St
+ { start_code = 0
+ , brace_depth = 0
+ }
+
+-- Tokens
+
+data Token
+ = TEOF {t_str :: String}
+ | TOpenBrace {t_str :: String}
+ | TCloseBrace {t_str :: String}
+ | TOpenBracket {t_str :: String}
+ | TCloseBracket {t_str :: String}
+ | THash {t_str :: String}
+ | THashHash {t_str :: String}
+ | TOpenParen {t_str :: String}
+ | TCloseParen {t_str :: String}
+ | TLtColon {t_str :: String}
+ | TColonGt {t_str :: String}
+ | TLtPercent {t_str :: String}
+ | TPercentGt {t_str :: String}
+ | TPercentColon {t_str :: String}
+ | TPercentColonTwice {t_str :: String}
+ | TSemi {t_str :: String}
+ | TColon {t_str :: String}
+ | TDotDotDot {t_str :: String}
+ | TNew {t_str :: String}
+ | TDelete {t_str :: String}
+ | TQuestion {t_str :: String}
+ | TColonColon {t_str :: String}
+ | TDot {t_str :: String}
+ | TDotStar {t_str :: String}
+ | TPlus {t_str :: String}
+ | TMinus {t_str :: String}
+ | TStar {t_str :: String}
+ | TSlash {t_str :: String}
+ | TPercent {t_str :: String}
+ | TUpArrow {t_str :: String}
+ | TAmpersand {t_str :: String}
+ | TPipe {t_str :: String}
+ | TTilde {t_str :: String}
+ | TExclamation {t_str :: String}
+ | TEqual {t_str :: String}
+ | TOpenAngle {t_str :: String}
+ | TCloseAngle {t_str :: String}
+ | TPlusEqual {t_str :: String}
+ | TMinusEqual {t_str :: String}
+ | TStarEqual {t_str :: String}
+ | TSlashEqual {t_str :: String}
+ | TPercentEqual {t_str :: String}
+ | TUpEqual {t_str :: String}
+ | TAmpersandEqual {t_str :: String}
+ | TPipeEqual {t_str :: String}
+ | TLtLt {t_str :: String}
+ | TGtGt {t_str :: String}
+ | TGtGtEqual {t_str :: String}
+ | TLtLtEqual {t_str :: String}
+ | TEqualEqual {t_str :: String}
+ | TExclaimEqual {t_str :: String}
+ | TLtEqual {t_str :: String}
+ | TGtEqual {t_str :: String}
+ | TAmpersandTwice {t_str :: String}
+ | TPipePipe {t_str :: String}
+ | TPlusPlus {t_str :: String}
+ | TMinusMinus {t_str :: String}
+ | TComma {t_str :: String}
+ | TMinusGtStar {t_str :: String}
+ | TMinusGt {t_str :: String}
+ | TAnd {t_str :: String}
+ | TAndEq {t_str :: String}
+ | TBitand {t_str :: String}
+ | TBitor {t_str :: String}
+ | TCompl {t_str :: String}
+ | TNot {t_str :: String}
+ | TNotEq {t_str :: String}
+ | TOr {t_str :: String}
+ | TOrEq {t_str :: String}
+ | TXor {t_str :: String}
+ | TXorEq {t_str :: String}
+ | TLowerName {t_str :: String}
+ | TUpperName {t_str :: String}
+ | TString {t_str :: String}
+ | TInteger {t_str :: String}
+ | TOther {t_str :: String}
+ deriving (Show)
+
+-- Actions
+
+type Action = String -> ParserM Token
+
+setStartCode :: StartCode -> ParserM ()
+setStartCode sc = ParserM $ \i st -> Right (i, st{start_code = sc}, ())
+
+andBegin :: Action -> StartCode -> Action
+(act `andBegin` sc) x = do
+ setStartCode sc
+ act x
+
+mkT :: Token -> Action
+mkT t = mkTv (const t)
+
+mkTv :: (String -> Token) -> Action
+mkTv f str = ParserM (\i st -> Right (i, st, f str))
+
+-- begin :: Int -> Action
+-- begin sc _span _buf _len _buf2 =
+-- do setStartCode sc
+-- lex_tok
+
+-- Positions
+
+data Pos = Pos !Int {- Line -} !Int {- Column -}
+ deriving (Show)
+
+get_pos :: ParserM Pos
+get_pos = ParserM $ \i@(AlexInput p _ _) st -> Right (i, st, p)
+
+alexMove :: Pos -> Char -> Pos
+alexMove (Pos l _) '\n' = Pos (l + 1) 1
+alexMove (Pos l c) '\t' = Pos l ((c + 8) `div` 8 * 8)
+alexMove (Pos l c) _ = Pos l (c + 1)
+
+init_pos :: Pos
+init_pos = Pos 1 0
+
+show_pos :: Pos -> String
+show_pos (Pos l c) = "line " ++ show l ++ ", column " ++ show c
+
+-- Input
+
+data AlexInput = AlexInput
+ { position :: !Pos
+ , char_bytes :: [Word8]
+ , input :: String
+ }
+ deriving (Show)
+
+alexGetByte :: AlexInput -> Maybe (Word8, AlexInput)
+alexGetByte (AlexInput p (w : ws) cs) =
+ Just (w, AlexInput p ws cs)
+alexGetByte (AlexInput p [] (c : cs)) =
+ alexGetByte (AlexInput (alexMove p c) (utf8_encode c) cs)
+alexGetByte (AlexInput _ [] []) =
+ Nothing
+
+-- annoyingly, this doesn't seem to exist anywhere else as a standalone function
+utf8_encode :: Char -> [Word8]
+utf8_encode c = case ord c of
+ n
+ | n < 0x80 -> [fromIntegral n]
+ | n < 0x800 ->
+ [ fromIntegral $ 0b11000000 .|. (n `shiftR` 6)
+ , fromIntegral $ 0b10000000 .|. (n .&. 0b111111)
+ ]
+ | n < 0x10000 ->
+ [ fromIntegral $ 0b11100000 .|. (n `shiftR` 12)
+ , fromIntegral $ 0b10000000 .|. ((n `shiftR` 6) .&. 0b111111)
+ , fromIntegral $ 0b10000000 .|. (n .&. 0b111111)
+ ]
+ | otherwise ->
+ [ fromIntegral $ 0b11110000 .|. (n `shiftR` 18)
+ , fromIntegral $ 0b10000000 .|. ((n `shiftR` 12) .&. 0b111111)
+ , fromIntegral $ 0b10000000 .|. ((n `shiftR` 6) .&. 0b111111)
+ , fromIntegral $ 0b10000000 .|. (n .&. 0b111111)
+ ]
+
+alexInputPrevChar :: AlexInput -> Char
+alexInputPrevChar _ = error "Lexer doesn't implement alexInputPrevChar"
+
+happyError :: ParserM a
+happyError = do
+ p <- get_pos
+ fail $ "Parse error at " ++ show_pos p
=====================================
utils/check-cpp/PreProcess.hs
=====================================
@@ -14,32 +14,36 @@ import GHC.Types.SrcLoc
import Debug.Trace
+import Macro
+
+-- import ParseOld
import Parse
+import Types
-- ---------------------------------------------------------------------
type PP = P PpState
-initPpState :: PpState
-initPpState =
- PpState
- { pp_defines = Map.empty
- , pp_includes = Map.empty
- , pp_include_stack = []
- , pp_continuation = []
- , pp_context = []
- , pp_accepting = True
- }
-
-data PpState = PpState
- { pp_defines :: !(Map String [String])
- , pp_includes :: !(Map String StringBuffer)
- , pp_include_stack :: ![Lexer.AlexInput]
- , pp_continuation :: ![Located Token]
- , pp_context :: ![Token] -- What preprocessor directive we are currently processing
- , pp_accepting :: !Bool
- }
- deriving (Show)
+-- initPpState :: PpState
+-- initPpState =
+-- PpState
+-- { pp_defines = Map.empty
+-- , pp_includes = Map.empty
+-- , pp_include_stack = []
+-- , pp_continuation = []
+-- , pp_context = []
+-- , pp_accepting = True
+-- }
+
+-- data PpState = PpState
+-- { pp_defines :: !(Map String [String])
+-- , pp_includes :: !(Map String StringBuffer)
+-- , pp_include_stack :: ![Lexer.AlexInput]
+-- , pp_continuation :: ![Located Token]
+-- , pp_context :: ![Token] -- What preprocessor directive we are currently processing
+-- , pp_accepting :: !Bool
+-- }
+-- deriving (Show)
-- deriving instance Show Lexer.AlexInput
-- ---------------------------------------------------------------------
@@ -124,6 +128,9 @@ processCpp fs = do
ppInclude filename
Right (CppDefine name def) -> do
ppDefine name def
+ Right (CppIf cond) -> do
+ ppIf cond
+ return ()
Right (CppIfdef name) -> do
defined <- ppIsDefined name
setAccepting defined
@@ -237,12 +244,21 @@ ppInclude filename = do
ppDefine :: String -> [String] -> PP ()
ppDefine name val = P $ \s ->
-- POk s{pp = (pp s){pp_defines = Set.insert (cleanTokenString def) (pp_defines (pp s))}} ()
- POk s{pp = (pp s){pp_defines = Map.insert (trace ("ppDefine:def=[" ++ name ++ "]") name) val (pp_defines (pp s))}} ()
+ POk s{pp = (pp s){pp_defines = Map.insert (trace ("ppDefine:def=[" ++ name ++ "]") (MacroName name Nothing)) val (pp_defines (pp s))}} ()
ppIsDefined :: String -> PP Bool
ppIsDefined def = P $ \s ->
-- POk s (Map.member def (pp_defines (pp s)))
- POk s (Map.member (trace ("ppIsDefined:def=[" ++ def ++ "]") def) (pp_defines (pp s)))
+ POk s (Map.member (trace ("ppIsDefined:def=[" ++ def ++ "]") (MacroName def Nothing)) (pp_defines (pp s)))
+
+ppIf :: [String] -> PP Bool
+ppIf toks = P $ \s ->
+ -- -- POk s (Map.member def (pp_defines (pp s)))
+ -- POk s (Map.member (trace ("ppIsDefined:def=[" ++ def ++ "]") def) (pp_defines (pp s)))
+ let
+ s' = cppIf (pp s) toks
+ in
+ POk s{pp = s'} (pp_accepting s')
-- | Take a @FastString@ of the form "#define FOO\n" and strip off all but "FOO"
cleanTokenString :: FastString -> String
=====================================
utils/check-cpp/README.md
=====================================
@@ -0,0 +1,8 @@
+
+Until the build works properly. do
+
+```
+alex Lexer.x
+```
+
+in this directory to make the lexer.
=====================================
utils/check-cpp/Types.hs
=====================================
@@ -0,0 +1,63 @@
+module Types where
+
+import GHC.Parser.Lexer (Token (..))
+import GHC.Types.SrcLoc
+import qualified GHC.Parser.Lexer as Lexer
+import GHC.Data.StringBuffer
+
+import Data.Map (Map)
+import qualified Data.Map as Map
+
+-- ---------------------------------------------------------------------
+
+initPpState :: PpState
+initPpState =
+ PpState
+ { pp_defines = Map.empty
+ , pp_includes = Map.empty
+ , pp_include_stack = []
+ , pp_continuation = []
+ , pp_context = []
+ , pp_accepting = True
+ }
+
+data PpState = PpState
+ { pp_defines :: !(Map MacroName MacroDef)
+ , pp_includes :: !(Map String StringBuffer)
+ , pp_include_stack :: ![Lexer.AlexInput]
+ , pp_continuation :: ![Located Token]
+ , pp_context :: ![Token] -- What preprocessor directive we are currently processing
+ , pp_accepting :: !Bool
+ }
+ deriving (Show)
+
+-- ---------------------------------------------------------------------
+
+data CppDirective
+ = CppInclude String
+ | CppDefine String [String]
+ | CppIfdef String
+ | CppIfndef String
+ | CppIf [String]
+ | CppElse
+ | CppEndif
+ deriving (Show, Eq)
+
+-- ---------------------------------------------------------------------
+
+type MacroArgs = [String]
+data MacroName = MacroName String (Maybe MacroArgs)
+ deriving (Show, Eq, Ord)
+type MacroDef = [String]
+
+-- data PpState = PpState
+-- { pp_defines :: !(Map MacroName MacroDef)
+-- , pp_accepting :: !Bool
+-- }
+-- deriving (Show, Eq)
+
+-- initPpState :: PpState
+-- initPpState = PpState{pp_defines = Map.empty, pp_accepting = True}
+
+type Input = String
+type Output = CppDirective
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/9c7e0f6989772855c535829f761e60ae396843dd...01f6c1eb7cf6fbb55d902f3d76f0a2b2707d2741
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/9c7e0f6989772855c535829f761e60ae396843dd...01f6c1eb7cf6fbb55d902f3d76f0a2b2707d2741
You're receiving this email because of your account on gitlab.haskell.org.
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20231025/13309c4f/attachment-0001.html>
More information about the ghc-commits
mailing list