aihc-cpp (empty) → 1.0.0.0
raw patch · 12 files changed
+3124/−0 lines, 12 filesdep +aihc-cppdep +basedep +bytestring
Dependencies added: aihc-cpp, base, bytestring, containers, cpphs, deepseq, directory, filepath, tasty, tasty-hunit, tasty-quickcheck, text
Files
- CHANGELOG.md +20/−0
- LICENSE +24/−0
- aihc-cpp.cabal +91/−0
- app/cpp-progress/Main.hs +43/−0
- src/Aihc/Cpp.hs +737/−0
- src/Aihc/Cpp/Cursor.hs +202/−0
- src/Aihc/Cpp/Evaluator.hs +631/−0
- src/Aihc/Cpp/Parser.hs +164/−0
- src/Aihc/Cpp/Scanner.hs +388/−0
- src/Aihc/Cpp/Types.hs +197/−0
- test/Spec.hs +330/−0
- test/Test/Progress.hs +297/−0
+ CHANGELOG.md view
@@ -0,0 +1,20 @@+# Changelog++All notable changes to `aihc-cpp` will be documented in this file.++The format is based on [Keep a Changelog](https://keepachangelog.com/en/1.1.0/).++## [Unreleased]++## [1.0.0.0] - 2026-05-27++### Added++- Initial stable release of the pure Haskell CPP package.+- Public preprocessing API with deterministic configuration, diagnostics,+ include continuations, and preprocessing results.+- Support for object-like and function-like macros, includes, conditionals,+ diagnostics, line directives, token pasting, stringification, predefined+ macro handling, and comment-aware scanning.+- Oracle-backed progress suite against cpphs with the current `46/46`+ implemented baseline.
+ LICENSE view
@@ -0,0 +1,24 @@+This is free and unencumbered software released into the public domain.++Anyone is free to copy, modify, publish, use, compile, sell, or+distribute this software, either in source code form or as a compiled+binary, for any purpose, commercial or non-commercial, and by any+means.++In jurisdictions that recognize copyright laws, the author or authors+of this software dedicate any and all copyright interest in the+software to the public domain. We make this dedication for the benefit+of the public at large and to the detriment of our heirs and+successors. We intend this dedication to be an overt act of+relinquishment in perpetuity of all present and future rights to this+software under copyright law.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,+EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF+MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.+IN NO EVENT SHALL THE AUTHORS BE LIABLE FOR ANY CLAIM, DAMAGES OR+OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE,+ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR+OTHER DEALINGS IN THE SOFTWARE.++For more information, please refer to <https://unlicense.org>
+ aihc-cpp.cabal view
@@ -0,0 +1,91 @@+cabal-version: 3.8+name: aihc-cpp+version: 1.0.0.0+build-type: Simple+license: Unlicense+license-file: LICENSE+extra-doc-files: CHANGELOG.md+author: David Himmelstrup+maintainer: lemmih@gmail.com+category: Development+synopsis: Pure Haskell C preprocessor for aihc+description:+ A pure Haskell C preprocessor for Haskell source files that use CPP. The+ package provides deterministic preprocessing with include continuations and+ oracle-backed tests against cpphs.++homepage: https://github.com/ai-haskell-compiler/aihc/tree/main/components/aihc-cpp+bug-reports: https://github.com/ai-haskell-compiler/aihc/issues++source-repository head+ type: git+ location: https://github.com/ai-haskell-compiler/aihc.git+ subdir: components/aihc-cpp++library+ exposed-modules:+ Aihc.Cpp++ other-modules:+ Aihc.Cpp.Cursor+ Aihc.Cpp.Evaluator+ Aihc.Cpp.Parser+ Aihc.Cpp.Scanner+ Aihc.Cpp.Types++ hs-source-dirs: src+ build-depends:+ base >=4.16 && <5,+ bytestring >=0.10.8 && <0.13,+ containers >=0.5 && <0.8,+ deepseq >=1.4 && <1.6,+ filepath >=1.3.0.1 && <1.6,+ text >=1.2 && <2.2,++ ghc-options: -Wall+ default-language: Haskell2010++test-suite spec+ type: exitcode-stdio-1.0+ hs-source-dirs: test+ main-is: Spec.hs+ other-modules:+ Test.Progress++ build-depends:+ aihc-cpp >=1.0 && <1.1,+ base >=4.16 && <5,+ bytestring >=0.10.8 && <0.13,+ containers >=0.5 && <0.8,+ cpphs >=1.20 && <1.21,+ directory >=1.2.3 && <1.5,+ filepath >=1.3.0.1 && <1.6,+ tasty >=1.5 && <1.6,+ tasty-hunit >=0.10 && <0.11,+ tasty-quickcheck >=0.11.1 && <0.12,+ text >=1.2 && <2.2,++ ghc-options: -Wall+ default-language: Haskell2010++executable cpp-progress+ hs-source-dirs:+ app/cpp-progress+ test++ main-is: Main.hs+ other-modules:+ Test.Progress++ build-depends:+ aihc-cpp >=1.0 && <1.1,+ base >=4.16 && <5,+ bytestring >=0.10.8 && <0.13,+ containers >=0.5 && <0.8,+ cpphs >=1.20 && <1.21,+ directory >=1.2.3 && <1.5,+ filepath >=1.3.0.1 && <1.6,+ text >=1.2 && <2.2,++ ghc-options: -Wall+ default-language: Haskell2010
+ app/cpp-progress/Main.hs view
@@ -0,0 +1,43 @@+module Main (main) where++import System.Environment (getArgs)+import System.Exit (exitFailure, exitSuccess)+import Test.Progress (CaseMeta (..), Outcome (..), evaluateCase, loadManifest, progressSummary)++main :: IO ()+main = do+ args <- getArgs+ let strict = "--strict" `elem` args+ cases <- loadManifest+ outcomes <- mapM evaluateCase cases+ let (passN, xfailN, xpassN, failN) = progressSummary outcomes+ totalN = passN + xfailN + xpassN + failN+ completion = pct (passN + xpassN) totalN+ putStrLn "Haskell CPP preprocessor progress"+ putStrLn "==============================="+ putStrLn ("PASS " <> show passN)+ putStrLn ("XFAIL " <> show xfailN)+ putStrLn ("XPASS " <> show xpassN)+ putStrLn ("FAIL " <> show failN)+ putStrLn ("TOTAL " <> show totalN)+ putStrLn ("COMPLETE " <> show completion <> "%")++ mapM_ printFail [(m, d) | (m, OutcomeFail, d) <- outcomes]+ mapM_ printXPass [(m, d) | (m, OutcomeXPass, d) <- outcomes]++ if failN == 0 && (not strict || xpassN == 0)+ then exitSuccess+ else exitFailure++printFail :: (CaseMeta, String) -> IO ()+printFail (meta, details) =+ putStrLn ("FAIL " <> caseId meta <> " [" <> caseCategory meta <> "] " <> details)++printXPass :: (CaseMeta, String) -> IO ()+printXPass (meta, details) =+ putStrLn ("XPASS " <> caseId meta <> " [" <> caseCategory meta <> "] " <> details)++pct :: Int -> Int -> Double+pct done totalN+ | totalN <= 0 = 0.0+ | otherwise = fromIntegral (done * 10000 `div` totalN) / 100.0
+ src/Aihc/Cpp.hs view
@@ -0,0 +1,737 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE OverloadedStrings #-}++-- |+-- Module : Aihc.Cpp+-- Description : Pure Haskell C preprocessor for Haskell source files+-- License : Unlicense+--+-- This module provides a C preprocessor implementation designed for+-- preprocessing Haskell source files that use CPP extensions.+--+-- The main entry point is 'preprocess', which takes a 'Config' and+-- source 'ByteString', returning a 'Step' that either completes with a+-- 'Result' or requests an include file to be resolved.+module Aihc.Cpp+ ( -- * Preprocessing+ preprocess,++ -- * Configuration+ Config (..),+ defaultConfig,++ -- * Results+ Step (..),+ Result (..),++ -- * Include Handling+ IncludeRequest (..),+ IncludeKind (..),++ -- * Diagnostics+ Diagnostic (..),+ Severity (..),+ )+where++import Aihc.Cpp.Cursor+ ( Cursor (..),+ atEnd,+ findNewline,+ fromByteString,+ lineSlice,+ peekByte,+ peekByteAt,+ skipNewline,+ skipWhile,+ sliceText,+ toText,+ )+import Aihc.Cpp.Evaluator (evalCondition)+import Aihc.Cpp.Parser (Directive (..), parseDirective)+import Aihc.Cpp.Scanner (expandLineBySpanMultiline, lineScanFinalCDepth, lineScanFinalHsDepth, lineScanSpans, scanLine, scanLineDepthOnly)+import Aihc.Cpp.Types+ ( CondFrame (..),+ Config (..),+ Continuation,+ Diagnostic (..),+ EngineState (..),+ IncludeKind (..),+ IncludeRequest (..),+ LineContext (..),+ MacroDef (..),+ Result (..),+ Severity (..),+ Step (..),+ currentActive,+ defaultConfig,+ emptyState,+ mkFrame,+ )+import Data.ByteString (ByteString)+import qualified Data.ByteString as BS+import qualified Data.ByteString.Builder as BSB+import qualified Data.ByteString.Lazy as BSL+import Data.Char (isSpace)+import Data.Map.Strict (Map)+import qualified Data.Map.Strict as M+import Data.Maybe (fromMaybe)+import qualified Data.Set as S+import Data.Text (Text)+import qualified Data.Text as T+import qualified Data.Text.Lazy as TL+import qualified Data.Text.Lazy.Builder as TB+import System.FilePath (takeDirectory, (</>))++-- $setup+-- >>> :set -XOverloadedStrings+-- >>> import qualified Data.Map.Strict as M+-- >>> import qualified Data.Text as T+-- >>> import qualified Data.Text.IO as T++-- | Preprocess C preprocessor directives in the input.+--+-- This function handles:+--+-- * Macro definitions (@#define@) and expansion+-- * Conditional compilation (@#if@, @#ifdef@, @#ifndef@, @#elif@, @#else@, @#endif@)+-- * File inclusion (@#include@)+-- * Diagnostics (@#warning@, @#error@)+-- * Line control (@#line@)+-- * Predefined macros (@__FILE__@, @__LINE__@, @__DATE__@, @__TIME__@)+--+-- === Macro expansion+--+-- Object-like macros are expanded in the output:+--+-- >>> let Done r = preprocess defaultConfig "#define FOO 42\nThe answer is FOO"+-- >>> T.putStr (resultOutput r)+-- #line 1 "<input>"+-- <BLANKLINE>+-- The answer is 42+--+-- Function-like macros are also supported:+--+-- >>> let Done r = preprocess defaultConfig "#define MAX(a,b) ((a) > (b) ? (a) : (b))\nMAX(3, 5)"+-- >>> T.putStr (resultOutput r)+-- #line 1 "<input>"+-- <BLANKLINE>+-- ((3) > (5) ? (3) : (5))+--+-- === Conditional compilation+--+-- Conditional directives control which sections of code are included:+--+-- >>> :{+-- let Done r = preprocess defaultConfig+-- "#define DEBUG 1\n#if DEBUG\ndebug mode\n#else\nrelease mode\n#endif"+-- in T.putStr (resultOutput r)+-- :}+-- #line 1 "<input>"+-- <BLANKLINE>+-- <BLANKLINE>+-- debug mode+-- <BLANKLINE>+-- <BLANKLINE>+-- <BLANKLINE>+--+-- === Include handling+--+-- When an @#include@ directive is encountered, 'preprocess' returns a+-- 'NeedInclude' step. The caller must provide the contents of the included+-- file as a 'ByteString':+--+-- >>> :{+-- let NeedInclude req k = preprocess defaultConfig "#include \"header.h\"\nmain code"+-- Done r = k (Just "-- header content")+-- in T.putStr (resultOutput r)+-- :}+-- #line 1 "<input>"+-- #line 1 "./header.h"+-- -- header content+-- #line 2 "<input>"+-- main code+--+-- If the include file is not found, pass 'Nothing' to emit an error:+--+-- >>> :{+-- let NeedInclude _ k = preprocess defaultConfig "#include \"missing.h\""+-- Done r = k Nothing+-- in do+-- T.putStr (resultOutput r)+-- mapM_ print (resultDiagnostics r)+-- :}+-- #line 1 "<input>"+-- Diagnostic {diagSeverity = Error, diagMessage = "missing include: missing.h", diagFile = "<input>", diagLine = 1}+--+-- === Diagnostics+--+-- The @#warning@ directive emits a warning:+--+-- >>> :{+-- let Done r = preprocess defaultConfig "#warning This is a warning"+-- in do+-- T.putStr (resultOutput r)+-- mapM_ print (resultDiagnostics r)+-- :}+-- #line 1 "<input>"+-- <BLANKLINE>+-- Diagnostic {diagSeverity = Warning, diagMessage = "This is a warning", diagFile = "<input>", diagLine = 1}+--+-- The @#error@ directive emits an error and stops preprocessing:+--+-- >>> :{+-- let Done r = preprocess defaultConfig "#error Build failed\nthis line is not processed"+-- in do+-- T.putStr (resultOutput r)+-- mapM_ print (resultDiagnostics r)+-- :}+-- #line 1 "<input>"+-- <BLANKLINE>+-- Diagnostic {diagSeverity = Error, diagMessage = "Build failed", diagFile = "<input>", diagLine = 1}+preprocess :: Config -> ByteString -> Step+preprocess cfg input =+ let cursor = fromByteString input+ in processFile (configInputFile cfg) cursor False [] 1 initialState finish+ where+ initialState =+ let st0 = emitLine (linePragma 1 (configInputFile cfg)) (emptyState (configInputFile cfg))+ in st0+ { stMacros = M.map ObjectMacro (configMacros cfg)+ }++ finish st =+ let out = TL.toStrict (TB.toLazyText (stOutput st))+ outWithTrailingNewline =+ if T.null out+ then out+ else out <> "\n"+ in Done+ Result+ { resultOutput = outWithTrailingNewline,+ resultDiagnostics = reverse (stDiagnosticsRev st)+ }++-- | Find the next line in the cursor, handling backslash-continuation+-- for directive lines. Returns (lineCursor, lineSpan, restCursor) where:+-- * lineCursor is a sub-cursor bounded to the logical line content+-- * lineSpan is the number of physical lines consumed (>= 1)+-- * restCursor is positioned after the line (past the newline)+--+-- Backslash-continuation is only applied when the line starts with '#'+-- (after optional whitespace), matching CPP semantics.+-- For continuation lines, a new ByteString is allocated with the+-- backslash-newline sequences removed.+nextLine :: Cursor -> (Cursor, Int, Cursor)+nextLine cur =+ let eol = findNewline cur+ lineStart = curPos cur+ lineEnd = curPos eol+ rest = fromMaybe eol (skipNewline eol)+ in if lineEnd > lineStart+ && peekByteAt (lineEnd - 1) cur == Just 0x5C -- '\' at end+ && isDirectiveLine cur lineEnd+ then -- Backslash continuation: join lines, stripping '\' and '\n'+ joinContinuationLines cur lineStart lineEnd rest+ else+ let lineText = sliceText lineStart lineEnd cur+ in if hasGccStringContinuation emptyQuoteState lineText+ then joinStringContinuationLines cur lineStart lineEnd rest+ else (lineSlice lineEnd cur, 1, rest)++-- | Check if the bytes from curPos to lineEnd start with '#' after+-- optional whitespace. This determines whether backslash-continuation+-- applies.+isDirectiveLine :: Cursor -> Int -> Bool+isDirectiveLine cur lineEnd =+ let trimmed = skipWhile isSpaceOrTab cur+ in curPos trimmed < lineEnd+ && peekByte trimmed == Just 0x23 -- '#'+ where+ isSpaceOrTab b = b == 0x20 || b == 0x09++-- | Join backslash-continuation lines into a single logical line.+-- Builds a new ByteString with '\<newline>' sequences removed.+-- Returns (joinedCursor, physicalLineCount, restCursor).+joinContinuationLines :: Cursor -> Int -> Int -> Cursor -> (Cursor, Int, Cursor)+joinContinuationLines origCur lineStart firstLineEnd firstRest =+ let buf = curBuf origCur+ -- First segment: from lineStart to firstLineEnd - 1 (exclude '\')+ firstSegment = BSB.byteString (sliceBS lineStart (firstLineEnd - 1) buf)+ in go firstSegment 1 firstRest+ where+ go !acc !spanCount !rest+ | atEnd rest =+ -- No more input; finalize+ let joined = BSL.toStrict (BSB.toLazyByteString acc)+ in (fromByteString joined, spanCount, rest)+ | otherwise =+ let eol = findNewline rest+ segStart = curPos rest+ segEnd = curPos eol+ rest' = fromMaybe eol (skipNewline eol)+ in if segEnd > segStart+ && peekByteAt (segEnd - 1) origCur == Just 0x5C -- ends with '\'+ then+ -- Another continuation line: append without the trailing '\'+ let segment = BSB.byteString (sliceBS segStart (segEnd - 1) (curBuf origCur))+ in go (acc <> segment) (spanCount + 1) rest'+ else+ -- Last line of continuation+ let segment = BSB.byteString (sliceBS segStart segEnd (curBuf origCur))+ joined = BSL.toStrict (BSB.toLazyByteString (acc <> segment))+ in (fromByteString joined, spanCount + 1, rest')++-- | Slice a ByteString from position @start@ to @end@ (exclusive).+sliceBS :: Int -> Int -> ByteString -> ByteString+sliceBS start end bs = BS.take (end - start) (BS.drop start bs)+{-# INLINE sliceBS #-}++data QuoteState = QuoteState+ { qsInString :: !Bool,+ qsInChar :: !Bool,+ qsEscaped :: !Bool+ }++emptyQuoteState :: QuoteState+emptyQuoteState = QuoteState False False False++-- | GCC removes @\<newline>@ before the Haskell lexer sees the file. Some+-- Haskell packages rely on that inside string gaps by writing lines that end+-- in @\\@: one backslash remains as the Haskell string-gap opener and the+-- final backslash is the CPP continuation marker. GHC's default CPP-like+-- handling also accepts the single-backslash spelling, so only the double+-- spelling is spliced here.+hasGccStringContinuation :: QuoteState -> Text -> Bool+hasGccStringContinuation st lineText =+ qsInString (scanQuoteState st lineText) && "\\\\" `T.isSuffixOf` lineText++joinStringContinuationLines :: Cursor -> Int -> Int -> Cursor -> (Cursor, Int, Cursor)+joinStringContinuationLines origCur lineStart firstLineEnd firstRest =+ let buf = curBuf origCur+ firstSegment = sliceText lineStart (firstLineEnd - 1) origCur+ firstBytes = BSB.byteString (sliceBS lineStart (firstLineEnd - 1) buf)+ in go firstBytes 1 firstRest (scanQuoteState emptyQuoteState firstSegment)+ where+ go !acc !spanCount !rest !quoteState+ | atEnd rest =+ let joined = BSL.toStrict (BSB.toLazyByteString acc)+ in (fromByteString joined, spanCount, rest)+ | otherwise =+ let eol = findNewline rest+ segStart = curPos rest+ segEnd = curPos eol+ rest' = fromMaybe eol (skipNewline eol)+ segmentText = sliceText segStart segEnd origCur+ in if hasGccStringContinuation quoteState segmentText+ then+ let segmentBytes = BSB.byteString (sliceBS segStart (segEnd - 1) (curBuf origCur))+ scannedText = sliceText segStart (segEnd - 1) origCur+ in go (acc <> segmentBytes) (spanCount + 1) rest' (scanQuoteState quoteState scannedText)+ else+ let segmentBytes = BSB.byteString (sliceBS segStart segEnd (curBuf origCur))+ joined = BSL.toStrict (BSB.toLazyByteString (acc <> segmentBytes))+ in (fromByteString joined, spanCount + 1, rest')++scanQuoteState :: QuoteState -> Text -> QuoteState+scanQuoteState = go+ where+ go st txt =+ case T.uncons txt of+ Nothing -> st+ Just (c, rest)+ | qsInString st ->+ if qsEscaped st && isSpace c+ then go st {qsEscaped = False} (dropStringGapClose rest)+ else+ go+ st+ { qsInString = qsEscaped st || c /= '"',+ qsEscaped = c == '\\' && not (qsEscaped st)+ }+ rest+ | qsInChar st ->+ go+ st+ { qsInChar = qsEscaped st || c /= '\'',+ qsEscaped = c == '\\' && not (qsEscaped st)+ }+ rest+ | c == '"' -> go (QuoteState True False False) rest+ | c == '\'' -> go (QuoteState False True False) rest+ | otherwise -> go st {qsEscaped = False} rest++ dropStringGapClose txt =+ let afterSpace = T.dropWhile isSpace txt+ in case T.uncons afterSpace of+ Just ('\\', rest) -> rest+ _ -> afterSpace++-- | Process a file from a cursor. The @trailingNewline@ flag controls+-- whether a trailing newline in the input produces an extra empty line+-- (used for include files to match @splitOn \"\\n\"@ semantics).+processFile :: FilePath -> Cursor -> Bool -> [CondFrame] -> Int -> EngineState -> Continuation -> Step+processFile _ cursor trailingNl _ _ st k+ | atEnd cursor =+ if trailingNl+ then -- Include file: trailing newline produces one more empty line+ k (emitBlankLines 1 st)+ else k st+processFile filePath cursor trailingNl stack !lineNo st k =+ let (lineCur, lineSpan, restCursor) = nextLine cursor+ -- Detect if this line was followed by a newline (vs EOF).+ -- If so and restCursor is at EOF, the file had a trailing newline.+ hasTrailingNl = trailingNl && not (atEnd restCursor) || (trailingNl && atEnd restCursor)+ -- Actually: trailingNl flag is set at processFile entry for includes.+ -- We just propagate it. The check at atEnd above handles the final empty line.+ lineText = toText lineCur+ startsInBlockComment = stHsBlockCommentDepth st > 0 || stCBlockCommentDepth st > 0+ parsedDirective =+ if startsInBlockComment+ then Nothing+ else parseDirective lineText+ isActive = currentActive stack+ nextLineNo = lineNo + lineSpan+ in if not isActive && not (stSkippingDanglingElse st)+ then -- === Fast path for inactive branches ===+ -- Only track comment depth; skip full span scanning and macro expansion.+ let (finalHs, finalC) = scanLineDepthOnly (stHsBlockCommentDepth st) (stCBlockCommentDepth st) lineCur+ advanceSt st' =+ st'+ { stCurrentLine = nextLineNo,+ stHsBlockCommentDepth = finalHs,+ stCBlockCommentDepth = finalC+ }+ continueInactive st' = processFile filePath restCursor hasTrailingNl stack nextLineNo (advanceSt st') k+ continueInactiveWith stack' st' = processFile filePath restCursor hasTrailingNl stack' nextLineNo (advanceSt st') k+ in case parsedDirective of+ Nothing ->+ continueInactive (emitBlankLines lineSpan st)+ Just directive ->+ let ctx =+ LineContext+ { lcFilePath = filePath,+ lcLineNo = lineNo,+ lcLineSpan = lineSpan,+ lcNextLineNo = nextLineNo,+ lcRestCursor = restCursor,+ lcStack = stack,+ lcContinue = continueInactive,+ lcContinueWith = continueInactiveWith,+ lcDone = k+ }+ in handleDirective ctx st directive+ else -- === Normal path: full scan + expansion ===+ let lineScan = scanLine (stHsBlockCommentDepth st) (stCBlockCommentDepth st) lineCur+ advanceLineState st' =+ st'+ { stCurrentLine = nextLineNo,+ stHsBlockCommentDepth = lineScanFinalHsDepth lineScan,+ stCBlockCommentDepth = lineScanFinalCDepth lineScan+ }+ continue st' = processFile filePath restCursor hasTrailingNl stack nextLineNo (advanceLineState st') k+ continueWith stack' st' = processFile filePath restCursor hasTrailingNl stack' nextLineNo (advanceLineState st') k+ ctx =+ LineContext+ { lcFilePath = filePath,+ lcLineNo = lineNo,+ lcLineSpan = lineSpan,+ lcNextLineNo = nextLineNo,+ lcRestCursor = restCursor,+ lcStack = stack,+ lcContinue = continue,+ lcContinueWith = continueWith,+ lcDone = k+ }+ in if stSkippingDanglingElse st+ then recoverDanglingElse ctx parsedDirective st+ else case parsedDirective of+ Nothing ->+ -- Try multi-line expansion: look ahead at future lines via cursor+ let (expanded, extraConsumed) =+ expandLineBySpanMultiline st (lineScanSpans lineScan) restCursor+ in if extraConsumed > 0+ then+ -- Skip consumed continuation lines by advancing the cursor+ let (remainingCursor, totalExtraSpan) =+ skipNLines extraConsumed restCursor+ -- Scan consumed lines to update comment depths+ (finalHs, finalC) =+ scanConsumedLines+ (lineScanFinalHsDepth lineScan)+ (lineScanFinalCDepth lineScan)+ restCursor+ extraConsumed+ nextLineNo' = nextLineNo + totalExtraSpan+ st' =+ (emitLine expanded st)+ { stCurrentLine = nextLineNo',+ stHsBlockCommentDepth = finalHs,+ stCBlockCommentDepth = finalC+ }+ in processFile filePath remainingCursor hasTrailingNl stack nextLineNo' st' k+ else continue (emitLine expanded st)+ Just directive ->+ handleDirective ctx st directive++-- | Skip N lines from a cursor, returning (rest cursor, total lines skipped).+skipNLines :: Int -> Cursor -> (Cursor, Int)+skipNLines 0 cur = (cur, 0)+skipNLines n cur = go 0 0 cur+ where+ go !count !consumed !c+ | count >= n = (c, consumed)+ | atEnd c = (c, consumed)+ | otherwise =+ let eol = findNewline c+ rest = fromMaybe eol (skipNewline eol)+ in go (count + 1) (consumed + 1) rest++-- | Scan consumed lines to update comment depths.+scanConsumedLines :: Int -> Int -> Cursor -> Int -> (Int, Int)+scanConsumedLines !hsDepth !cDepth _cur 0 = (hsDepth, cDepth)+scanConsumedLines !hsDepth !cDepth cur remaining+ | atEnd cur = (hsDepth, cDepth)+ | otherwise =+ let eol = findNewline cur+ lineCur = lineSlice (curPos eol) cur+ (hsDepth', cDepth') = scanLineDepthOnly hsDepth cDepth lineCur+ rest = fromMaybe eol (skipNewline eol)+ in scanConsumedLines hsDepth' cDepth' rest (remaining - 1)++recoverDanglingElse :: LineContext -> Maybe Directive -> EngineState -> Step+recoverDanglingElse ctx parsedDirective st =+ case parsedDirective of+ Just DirEndIf ->+ lcContinue+ ctx+ ( addDiag+ Warning+ "unmatched #endif"+ (lcFilePath ctx)+ (lcLineNo ctx)+ (st {stSkippingDanglingElse = False})+ )+ Just _ ->+ lcContinue ctx st+ Nothing ->+ lcContinue ctx (emitDirectiveBlank ctx st)++handleDirective :: LineContext -> EngineState -> Directive -> Step+handleDirective ctx st directive =+ case directive of+ DirDefineObject name value ->+ mutateMacrosWhenActive ctx st (M.insert name (ObjectMacro value))+ DirDefineFunction name params body ->+ mutateMacrosWhenActive ctx st (M.insert name (FunctionMacro params body))+ DirUndef name ->+ mutateMacrosWhenActive ctx st (M.delete name)+ DirInclude kind includeTarget ->+ handleIncludeDirective ctx st kind includeTarget+ DirIf expr ->+ pushConditionalFrame ctx st (evalCondition st expr)+ DirIfDef name ->+ pushConditionalFrame ctx st (M.member name (stMacros st))+ DirIfNDef name ->+ pushConditionalFrame ctx st (not (M.member name (stMacros st)))+ DirElif expr ->+ handleElifDirective ctx st expr+ DirElse ->+ handleElseDirective ctx st+ DirEndIf ->+ case lcStack ctx of+ [] ->+ lcContinue+ ctx+ (addDiag Warning "unmatched #endif" (lcFilePath ctx) (lcLineNo ctx) st)+ _ : rest ->+ continueBlankWithStack ctx rest st+ DirWarning msg ->+ addDiagnosticWhenActive ctx Warning msg st+ DirError msg ->+ if currentActive (lcStack ctx)+ then+ lcDone+ ctx+ (emitDirectiveBlank ctx (addDiag Error msg (lcFilePath ctx) (lcLineNo ctx) st))+ else continueBlank ctx st+ DirLine n mPath ->+ handleLineDirective ctx st n mPath+ DirPragmaOnce ->+ handlePragmaOnceDirective ctx st+ DirUnsupported name ->+ addDiagnosticWhenActive ctx Warning ("unsupported directive: " <> name) st++emitDirectiveBlank :: LineContext -> EngineState -> EngineState+emitDirectiveBlank ctx = emitBlankLines (lcLineSpan ctx)++continueBlank :: LineContext -> EngineState -> Step+continueBlank ctx st = lcContinue ctx (emitDirectiveBlank ctx st)++continueBlankWithStack :: LineContext -> [CondFrame] -> EngineState -> Step+continueBlankWithStack ctx stack st = lcContinueWith ctx stack (emitDirectiveBlank ctx st)++mutateMacrosWhenActive :: LineContext -> EngineState -> (Map Text MacroDef -> Map Text MacroDef) -> Step+mutateMacrosWhenActive ctx st mutate =+ if currentActive (lcStack ctx)+ then continueBlank ctx (st {stMacros = mutate (stMacros st)})+ else continueBlank ctx st++addDiagnosticWhenActive :: LineContext -> Severity -> Text -> EngineState -> Step+addDiagnosticWhenActive ctx severity message st =+ if currentActive (lcStack ctx)+ then continueBlank ctx (addDiag severity message (lcFilePath ctx) (lcLineNo ctx) st)+ else continueBlank ctx st++handlePragmaOnceDirective :: LineContext -> EngineState -> Step+handlePragmaOnceDirective ctx st =+ if currentActive (lcStack ctx)+ then continueBlank ctx (st {stPragmaOnceFiles = S.insert (lcFilePath ctx) (stPragmaOnceFiles st)})+ else continueBlank ctx st++pushConditionalFrame :: LineContext -> EngineState -> Bool -> Step+pushConditionalFrame ctx st cond =+ let frame = mkFrame (currentActive (lcStack ctx)) cond+ in continueBlankWithStack ctx (frame : lcStack ctx) st++handleElifDirective :: LineContext -> EngineState -> Text -> Step+handleElifDirective ctx st expr =+ case lcStack ctx of+ [] ->+ continueBlank+ ctx+ (addDiag Error "#elif without matching #if" (lcFilePath ctx) (lcLineNo ctx) st)+ f : rest ->+ if frameInElse f+ then+ continueBlank+ ctx+ (addDiag Error "#elif after #else" (lcFilePath ctx) (lcLineNo ctx) st)+ else+ let anyTaken = frameConditionTrue f+ newCond = not anyTaken && evalCondition st expr+ f' =+ f+ { frameConditionTrue = anyTaken || newCond,+ frameCurrentActive = frameOuterActive f && newCond+ }+ in continueBlankWithStack ctx (f' : rest) st++handleElseDirective :: LineContext -> EngineState -> Step+handleElseDirective ctx st =+ case lcStack ctx of+ [] ->+ lcContinue ctx (st {stSkippingDanglingElse = True})+ f : rest ->+ if frameInElse f+ then+ continueBlank+ ctx+ (addDiag Error "duplicate #else in conditional block" (lcFilePath ctx) (lcLineNo ctx) st)+ else+ let newCurrent = frameOuterActive f && not (frameConditionTrue f)+ f' =+ f+ { frameInElse = True,+ frameCurrentActive = newCurrent+ }+ in continueBlankWithStack ctx (f' : rest) st++handleIncludeDirective :: LineContext -> EngineState -> IncludeKind -> Text -> Step+handleIncludeDirective ctx st kind includeTarget+ | not (currentActive (lcStack ctx)) = continueBlank ctx st+ | S.member includeFilePath (stPragmaOnceFiles st) = continueBlank ctx st+ | otherwise = NeedInclude includeReq nextStep+ where+ includePathText = T.unpack includeTarget+ includeFilePath =+ case kind of+ IncludeLocal -> takeDirectory (lcFilePath ctx) </> includePathText+ IncludeSystem -> includePathText+ includeReq =+ IncludeRequest+ { includePath = includePathText,+ includeKind = kind,+ includeFrom = lcFilePath ctx,+ includeLine = lcLineNo ctx+ }++ nextStep Nothing =+ lcContinue+ ctx+ (addDiag Error ("missing include: " <> includeTarget) (lcFilePath ctx) (lcLineNo ctx) st)+ nextStep (Just includeBytes) =+ let includeCursor = fromByteString includeBytes+ -- Include files treat trailing newlines as producing an extra+ -- empty line (matching splitOn "\n" semantics).+ includeHasTrailingNl = not (BS.null includeBytes) && BS.last includeBytes == 0x0A+ stWithIncludePragma =+ emitLine (linePragma 1 includeFilePath) (st {stCurrentFile = includeFilePath, stCurrentLine = 1})+ resumeParent stAfterInclude =+ processFile+ (lcFilePath ctx)+ (lcRestCursor ctx)+ False+ (lcStack ctx)+ (lcNextLineNo ctx)+ ( emitLine+ (linePragma (lcNextLineNo ctx) (lcFilePath ctx))+ (stAfterInclude {stCurrentFile = lcFilePath ctx, stCurrentLine = lcNextLineNo ctx})+ )+ (lcDone ctx)+ in processFile includeFilePath includeCursor includeHasTrailingNl [] 1 stWithIncludePragma resumeParent++handleLineDirective :: LineContext -> EngineState -> Int -> Maybe FilePath -> Step+handleLineDirective ctx st lineNumber maybePath+ | not (currentActive (lcStack ctx)) = continueBlank ctx st+ | otherwise =+ let stWithFile =+ case maybePath of+ Just path -> st {stCurrentFile = path}+ Nothing -> st+ stWithLinePragma =+ emitLine+ (linePragma lineNumber (stCurrentFile stWithFile))+ (stWithFile {stCurrentLine = lineNumber})+ in processFile+ (lcFilePath ctx)+ (lcRestCursor ctx)+ False+ (lcStack ctx)+ lineNumber+ (stWithLinePragma {stCurrentLine = lineNumber})+ (lcDone ctx)++emitLine :: Text -> EngineState -> EngineState+emitLine line st =+ let sep = if stOutputLineCount st > 0 then TB.singleton '\n' else mempty+ in st+ { stOutput = stOutput st <> sep <> TB.fromText line,+ stOutputLineCount = stOutputLineCount st + 1+ }++emitBlankLines :: Int -> EngineState -> EngineState+emitBlankLines n st+ | n <= 0 = st+ | otherwise =+ let newlines = mconcat (replicate n (TB.singleton '\n'))+ in st+ { stOutput = stOutput st <> newlines,+ stOutputLineCount = stOutputLineCount st + n+ }++addDiag :: Severity -> Text -> FilePath -> Int -> EngineState -> EngineState+addDiag sev msg filePath lineNo st =+ st+ { stDiagnosticsRev =+ Diagnostic+ { diagSeverity = sev,+ diagMessage = msg,+ diagFile = filePath,+ diagLine = lineNo+ }+ : stDiagnosticsRev st+ }++linePragma :: Int -> FilePath -> Text+linePragma n path = "#line " <> T.pack (show n) <> " \"" <> T.pack path <> "\""
+ src/Aihc/Cpp/Cursor.hs view
@@ -0,0 +1,202 @@+{-# LANGUAGE BangPatterns #-}++-- |+-- Module : Aihc.Cpp.Cursor+-- Description : Zero-copy cursor over ByteString for efficient scanning+-- License : Unlicense+--+-- A lightweight cursor abstraction over a strict 'ByteString'. The cursor+-- tracks a position into a shared buffer, enabling O(1) peeking and+-- zero-copy slicing. All CPP-significant bytes are ASCII (0x00-0x7F),+-- so byte-level operations are safe; non-ASCII bytes (>= 0x80) can be+-- bulk-copied without decoding.+module Aihc.Cpp.Cursor+ ( Cursor (..),+ fromByteString,+ fromText,+ toText,+ null,+ peekByte,+ peekByte2,+ advance,+ advance2,+ sliceText,+ sliceSince,+ skipWhile,+ skipToInteresting,+ bufLength,++ -- * Line-oriented operations+ findNewline,+ skipNewline,+ lineSlice,+ startsWithByte,+ peekByteAt,+ atEnd,+ )+where++import Data.ByteString (ByteString)+import qualified Data.ByteString as BS+import Data.Text (Text)+import qualified Data.Text.Encoding as TE+import Data.Word (Word8)+import Prelude hiding (null)++-- | A position-based cursor into a 'ByteString' buffer.+-- The buffer is shared across all cursors derived from the same input,+-- enabling zero-copy slicing.+data Cursor = Cursor+ { curBuf :: {-# UNPACK #-} !ByteString,+ curPos :: {-# UNPACK #-} !Int+ }+ deriving (Show)++-- | Create a cursor at the start of a 'ByteString'.+fromByteString :: ByteString -> Cursor+fromByteString bs = Cursor bs 0++-- | Create a cursor from 'Text' by encoding to UTF-8.+fromText :: Text -> Cursor+fromText = fromByteString . TE.encodeUtf8++-- | Decode the remaining bytes from the cursor position as UTF-8 'Text'.+toText :: Cursor -> Text+toText (Cursor buf pos) = TE.decodeUtf8 (BS.drop pos buf)++-- | Is the cursor at the end of input?+null :: Cursor -> Bool+null (Cursor buf pos) = pos >= BS.length buf+{-# INLINE null #-}++-- | Check whether the cursor is at the end of input (synonym for 'null').+atEnd :: Cursor -> Bool+atEnd = null+{-# INLINE atEnd #-}++-- | Peek at the current byte without advancing. Returns 'Nothing' at end+-- of input.+peekByte :: Cursor -> Maybe Word8+peekByte (Cursor buf pos)+ | pos >= BS.length buf = Nothing+ | otherwise = Just (BS.index buf pos)+{-# INLINE peekByte #-}++-- | Peek at the current and next byte without advancing. Returns 'Nothing'+-- if fewer than 2 bytes remain.+peekByte2 :: Cursor -> Maybe (Word8, Word8)+peekByte2 (Cursor buf pos)+ | pos + 1 >= BS.length buf = Nothing+ | otherwise = Just (BS.index buf pos, BS.index buf (pos + 1))+{-# INLINE peekByte2 #-}++-- | Peek at a byte at an absolute position in the buffer.+peekByteAt :: Int -> Cursor -> Maybe Word8+peekByteAt absPos (Cursor buf _)+ | absPos < 0 || absPos >= BS.length buf = Nothing+ | otherwise = Just (BS.index buf absPos)+{-# INLINE peekByteAt #-}++-- | Advance the cursor by one byte.+advance :: Cursor -> Cursor+advance (Cursor buf pos) = Cursor buf (pos + 1)+{-# INLINE advance #-}++-- | Advance the cursor by two bytes.+advance2 :: Cursor -> Cursor+advance2 (Cursor buf pos) = Cursor buf (pos + 2)+{-# INLINE advance2 #-}++-- | Extract a zero-copy 'Text' slice from position @start@ to position+-- @end@ (exclusive) in the cursor's buffer.+sliceText :: Int -> Int -> Cursor -> Text+sliceText start end (Cursor buf _) =+ TE.decodeUtf8 (BS.take (end - start) (BS.drop start buf))+{-# INLINE sliceText #-}++-- | Extract a zero-copy 'Text' slice from the given start position to+-- the cursor's current position.+sliceSince :: Int -> Cursor -> Text+sliceSince start cur = sliceText start (curPos cur) cur+{-# INLINE sliceSince #-}++-- | Advance the cursor while the predicate holds for the current byte.+skipWhile :: (Word8 -> Bool) -> Cursor -> Cursor+skipWhile p = go+ where+ go !cur = case peekByte cur of+ Just b | p b -> go (advance cur)+ _ -> cur+{-# INLINE skipWhile #-}++-- | Total length of the underlying buffer.+bufLength :: Cursor -> Int+bufLength (Cursor buf _) = BS.length buf+{-# INLINE bufLength #-}++-- | Advance the cursor past bytes that cannot start any CPP-significant+-- two-character sequence. Stops at: @\"@ (0x22), @\'@ (0x27), @*@ (0x2A),+-- @-@ (0x2D), @/@ (0x2F), @\\@ (0x5C), @{@ (0x7B), @}@ (0x7D),+-- or end of input. This allows bulk-copying runs of plain text+-- (identifiers, whitespace, operators, non-ASCII UTF-8) without+-- per-byte dispatch.+skipToInteresting :: Cursor -> Cursor+skipToInteresting = go+ where+ go !cur = case peekByte cur of+ Nothing -> cur+ Just b+ | isInteresting b -> cur+ | otherwise -> go (advance cur)++ isInteresting :: Word8 -> Bool+ isInteresting b =+ b == 0x22 -- '"'+ || b == 0x27 -- '\''+ || b == 0x2A -- '*'+ || b == 0x2D -- '-'+ || b == 0x2F -- '/'+ || b == 0x5C -- '\\'+ || b == 0x7B -- '{'+ || b == 0x7D -- '}'+ {-# INLINE isInteresting #-}+{-# INLINE skipToInteresting #-}++-- | Find the next newline byte (0x0A) or EOF. Returns a cursor+-- positioned at the newline (or at EOF). The bytes from the+-- original position to the returned position form the line content+-- (without the newline).+findNewline :: Cursor -> Cursor+findNewline = go+ where+ go !cur = case peekByte cur of+ Nothing -> cur+ Just 0x0A -> cur -- '\n'+ Just _ -> go (advance cur)+{-# INLINE findNewline #-}++-- | Advance past a newline byte if the cursor is currently on one.+-- Returns 'Nothing' at EOF, 'Just cursor' after the newline otherwise.+skipNewline :: Cursor -> Maybe Cursor+skipNewline cur = case peekByte cur of+ Just 0x0A -> Just (advance cur) -- '\n'+ _ -> Nothing+{-# INLINE skipNewline #-}++-- | Create a cursor that views only the bytes from @curPos cur@ to @end@+-- (exclusive) in the same buffer. This is a logical "line slice" — a+-- sub-cursor bounded at @end@.+--+-- Implementation: creates a new cursor over a sub-ByteString. The+-- sub-ByteString shares the underlying memory (zero-copy via 'BS.take'+-- and 'BS.drop').+lineSlice :: Int -> Cursor -> Cursor+lineSlice end (Cursor buf start) =+ Cursor (BS.take (end - start) (BS.drop start buf)) 0+{-# INLINE lineSlice #-}++-- | Check if the byte at the cursor's current position matches the+-- given byte.+startsWithByte :: Word8 -> Cursor -> Bool+startsWithByte b cur = peekByte cur == Just b+{-# INLINE startsWithByte #-}
+ src/Aihc/Cpp/Evaluator.hs view
@@ -0,0 +1,631 @@+{-# LANGUAGE OverloadedStrings #-}++module Aihc.Cpp.Evaluator+ ( expandMacros,+ expandMacrosMultiline,+ substituteParams,+ evalCondition,+ evalNumeric,+ Token (..),+ tokenize,+ parseExpr,+ parseOr,+ parseAnd,+ parseEq,+ parseRel,+ parseAdd,+ parseMul,+ parseUnary,+ parseAtom,+ replaceDefined,+ replaceRemainingWithZero,+ )+where++import Aihc.Cpp.Parser (isIdentChar, isIdentStart, isOpChar)+import Aihc.Cpp.Types (EngineState (..), MacroDef (..))+import Data.Char (isDigit, isSpace)+import Data.Map.Strict (Map)+import qualified Data.Map.Strict as M+import Data.Set (Set)+import qualified Data.Set as S+import Data.Text (Text)+import qualified Data.Text as T+import qualified Data.Text.Lazy as TL+import qualified Data.Text.Lazy.Builder as TB+import qualified Data.Text.Read as TR++-- | Expand macros in a single piece of text using the blue-paint algorithm.+-- A single pass with a suppression set replaces the previous iterate-up-to-32+-- fixpoint approach.+expandMacros :: EngineState -> Text -> Text+expandMacros st txt =+ builderToText (expandBlue st S.empty False False False (TB.fromText txt))++-- | Expand macros with multi-line support. When a function-like macro call+-- spans multiple lines, continuation lines are consumed from @moreLines@.+-- Returns the expanded text and the number of extra lines consumed.+expandMacrosMultiline :: EngineState -> Text -> [Text] -> (Text, Int)+expandMacrosMultiline st txt moreLines =+ let extraNeeded = countExtraLinesConsumed st txt moreLines+ in if extraNeeded == 0+ then (expandMacros st txt, 0)+ else+ let combinedLines = txt : take extraNeeded moreLines+ combined = T.intercalate "\n" combinedLines+ expanded = expandMacros st combined+ in (expanded, extraNeeded)++-- | Count how many extra lines a function macro call consumes.+-- Scans the first line for an identifier that matches a function macro,+-- then checks if parseCallArgs needs to span into continuation lines.+countExtraLinesConsumed :: EngineState -> Text -> [Text] -> Int+countExtraLinesConsumed st txt moreLines = scanForFunctionMacro False False False txt+ where+ macros = stMacros st++ scanForFunctionMacro :: Bool -> Bool -> Bool -> Text -> Int+ scanForFunctionMacro _ _ _ t | T.null t = 0+ scanForFunctionMacro inString inChar escaped t =+ case T.uncons t of+ Nothing -> 0+ Just (c, rest)+ | inString ->+ let escaped' = c == '\\' && not escaped+ inString' = not (c == '"' && not escaped)+ in scanForFunctionMacro inString' False escaped' rest+ | inChar ->+ let escaped' = c == '\\' && not escaped+ inChar' = not (c == '\'' && not escaped)+ in scanForFunctionMacro False inChar' escaped' rest+ | startsHsBlockComment t ->+ let (_, remaining) = consumeHsBlockComment t+ in scanForFunctionMacro False False False remaining+ | c == '"' -> scanForFunctionMacro True False False rest+ | c == '\'' -> scanForFunctionMacro False True False rest+ | isIdentStart c ->+ let (ident, rest') = T.span isIdentChar t+ in case M.lookup ident macros of+ Just (FunctionMacro _ _) ->+ case tryMultilineCallArgs rest' of+ Just n -> n+ Nothing -> scanForFunctionMacro False False False rest'+ _ -> scanForFunctionMacro False False False rest'+ | otherwise -> scanForFunctionMacro False False False rest++ -- Try to parse function call args, potentially spanning multiple lines.+ -- Returns Just n if the call spans n extra lines, Nothing if no call.+ tryMultilineCallArgs :: Text -> Maybe Int+ tryMultilineCallArgs rest = seekOpenParen (T.dropWhile isSpace rest) 0++ seekOpenParen :: Text -> Int -> Maybe Int+ seekOpenParen remaining extraLines =+ case T.uncons remaining of+ Just ('(', afterOpen) ->+ findClosingParen 0 afterOpen extraLines+ Just _ ->+ Nothing+ Nothing ->+ case drop extraLines moreLines of+ [] -> Nothing+ (nextLine : _) ->+ seekOpenParen (T.dropWhile isSpace nextLine) (extraLines + 1)++ findClosingParen :: Int -> Text -> Int -> Maybe Int+ findClosingParen = goClosing False False False+ where+ goClosing :: Bool -> Bool -> Bool -> Int -> Text -> Int -> Maybe Int+ goClosing inString inChar escaped depth remaining extraLines =+ case T.uncons remaining of+ Nothing ->+ -- Need more lines+ case drop extraLines moreLines of+ [] -> Nothing -- No more lines, unclosed call+ (nextLine : _) ->+ goClosing inString inChar escaped depth (T.cons '\n' nextLine) (extraLines + 1)+ Just (ch, rest)+ | inString ->+ let escaped' = ch == '\\' && not escaped+ inString' = not (ch == '"' && not escaped)+ in goClosing inString' False escaped' depth rest extraLines+ | inChar ->+ let escaped' = ch == '\\' && not escaped+ inChar' = not (ch == '\'' && not escaped)+ in goClosing False inChar' escaped' depth rest extraLines+ | startsHsBlockComment remaining ->+ let (_, afterComment) = consumeHsBlockComment remaining+ in goClosing False False False depth afterComment extraLines+ | ch == '"' -> goClosing True False False depth rest extraLines+ | ch == '\'' -> goClosing False True False depth rest extraLines+ | ch == '(' -> goClosing False False False (depth + 1) rest extraLines+ | ch == ')' && depth > 0 -> goClosing False False False (depth - 1) rest extraLines+ | ch == ')' -> Just extraLines+ | otherwise -> goClosing False False False depth rest extraLines++-- | Blue-paint macro expansion engine. Uses a suppression set (@painted@)+-- to prevent infinite recursion instead of iterating to a fixpoint.+-- Output is accumulated via a lazy 'TB.Builder' for amortized O(n).+expandBlue :: EngineState -> Set Text -> Bool -> Bool -> Bool -> TB.Builder -> TB.Builder+expandBlue st painted inString inChar escaped input =+ let txt = builderToText input+ in goText st painted inString inChar escaped txt mempty++-- | Walk the input text, expanding macros with blue-paint suppression.+goText :: EngineState -> Set Text -> Bool -> Bool -> Bool -> Text -> TB.Builder -> TB.Builder+goText _ _ _ _ _ txt acc | T.null txt = acc+goText st painted inString inChar escaped txt acc =+ case T.uncons txt of+ Nothing -> acc+ Just (c, rest)+ | inString ->+ let escaped' = c == '\\' && not escaped+ inString' = not (c == '"' && not escaped)+ in goText st painted inString' False escaped' rest (acc <> TB.singleton c)+ | inChar ->+ let escaped' = c == '\\' && not escaped+ inChar' = not (c == '\'' && not escaped)+ in goText st painted False inChar' escaped' rest (acc <> TB.singleton c)+ | startsHsBlockComment txt ->+ let (commentText, remaining) = consumeHsBlockComment txt+ in goText st painted False False False remaining (acc <> TB.fromText commentText)+ | c == '"' ->+ goText st painted True False False rest (acc <> TB.singleton c)+ | c == '\'' ->+ goText st painted False True False rest (acc <> TB.singleton c)+ | isIdentStart c ->+ expandIdentBlue st painted txt acc+ | c == '-',+ Just ('-', _) <- T.uncons rest ->+ -- Haskell line comment: copy remainder verbatim without macro expansion+ acc <> TB.fromText txt+ | otherwise ->+ goText st painted False False False rest (acc <> TB.singleton c)++-- | Handle an identifier during blue-paint expansion.+expandIdentBlue :: EngineState -> Set Text -> Text -> TB.Builder -> TB.Builder+expandIdentBlue st painted txt acc =+ let (ident, rest) = T.span isIdentChar txt+ in if S.member ident painted+ then -- Blue-painted: copy verbatim, don't expand+ goText st painted False False False rest (acc <> TB.fromText ident)+ else case ident of+ "__LINE__" ->+ goText st painted False False False rest (acc <> TB.fromString (show (stCurrentLine st)))+ "__FILE__" ->+ goText st painted False False False rest (acc <> TB.fromString (show (stCurrentFile st)))+ _ ->+ case M.lookup ident (stMacros st) of+ Just (ObjectMacro replacement) ->+ let painted' = S.insert ident painted+ replacement' = normalizeObjectReplacement replacement+ expanded = builderToText (goText st painted' False False False replacement' mempty)+ in goText st painted False False False rest (acc <> TB.fromText expanded)+ Just (FunctionMacro params body) ->+ case parseCallArgs rest of+ Nothing ->+ goText st painted False False False rest (acc <> TB.fromText ident)+ Just (args, restAfter)+ | length args == length params ->+ let body' = substituteParamsBuilder (M.fromList (zip params args)) body+ painted' = S.insert ident painted+ expanded = builderToText (goText st painted' False False False body' mempty)+ in goText st painted False False False restAfter (acc <> TB.fromText expanded)+ | otherwise ->+ goText st painted False False False rest (acc <> TB.fromText ident)+ Nothing ->+ goText st painted False False False rest (acc <> TB.fromText ident)++-- | Normalize comments inside object-like macro replacement text while+-- preserving string and char literals. cpphs replaces @/* ... */@ with spaces+-- matching the width of the comment body, but treats empty @/**/@ as a token+-- pasting hack with zero width.+normalizeObjectReplacement :: Text -> Text+normalizeObjectReplacement = T.stripEnd . go False False False mempty+ where+ go :: Bool -> Bool -> Bool -> TB.Builder -> Text -> Text+ go _ _ _ acc txt | T.null txt = builderToText acc+ go inString inChar escaped acc txt =+ case T.uncons txt of+ Nothing -> builderToText acc+ Just (c, rest)+ | inString ->+ let escaped' = c == '\\' && not escaped+ inString' = not (c == '"' && not escaped)+ in go inString' False escaped' (acc <> TB.singleton c) rest+ | inChar ->+ let escaped' = c == '\\' && not escaped+ inChar' = not (c == '\'' && not escaped)+ in go False inChar' escaped' (acc <> TB.singleton c) rest+ | c == '"' -> go True False False (acc <> TB.singleton c) rest+ | c == '\'' -> go False True False (acc <> TB.singleton c) rest+ | "/*" `T.isPrefixOf` txt ->+ let (commentText, remaining) = consumeCBlockComment txt+ replacement = commentReplacement commentText+ in go False False False (acc <> TB.fromText replacement) remaining+ | otherwise ->+ go False False False (acc <> TB.singleton c) rest++consumeCBlockComment :: Text -> (Text, Text)+consumeCBlockComment txt =+ let afterOpen = T.drop 2 txt+ (inside, suffix) = T.breakOn "*/" afterOpen+ in if T.null suffix+ then (txt, "")+ else ("/*" <> inside <> "*/", T.drop 2 suffix)++commentReplacement :: Text -> Text+commentReplacement commentText+ | commentText == "/**/" = ""+ | otherwise = T.replicate (T.length (commentBody commentText)) " "++commentBody :: Text -> Text+commentBody commentText =+ if "/*" `T.isPrefixOf` commentText && "*/" `T.isSuffixOf` commentText+ then T.dropEnd 2 (T.drop 2 commentText)+ else T.drop 2 commentText++-- | Parse function-like macro call arguments.+parseCallArgs :: Text -> Maybe ([Text], Text)+parseCallArgs input = do+ ('(', rest) <- T.uncons (T.dropWhile isSpace input)+ parseArgs False False False 0 [] mempty rest++parseArgs :: Bool -> Bool -> Bool -> Int -> [Text] -> TB.Builder -> Text -> Maybe ([Text], Text)+parseArgs inString inChar escaped depth argsRev current remaining =+ case T.uncons remaining of+ Nothing -> Nothing+ Just (ch, rest)+ | inString ->+ let escaped' = ch == '\\' && not escaped+ inString' = not (ch == '"' && not escaped)+ in parseArgs inString' False escaped' depth argsRev (current <> TB.singleton ch) rest+ | inChar ->+ let escaped' = ch == '\\' && not escaped+ inChar' = not (ch == '\'' && not escaped)+ in parseArgs False inChar' escaped' depth argsRev (current <> TB.singleton ch) rest+ | startsHsBlockComment remaining ->+ let (commentText, afterComment) = consumeHsBlockComment remaining+ in parseArgs False False False depth argsRev (current <> TB.fromText commentText) afterComment+ | ch == '"' ->+ parseArgs True False False depth argsRev (current <> TB.singleton ch) rest+ | ch == '\'' ->+ parseArgs False True False depth argsRev (current <> TB.singleton ch) rest+ | ch == '(' ->+ parseArgs False False False (depth + 1) argsRev (current <> TB.singleton ch) rest+ | ch == ')' && depth > 0 ->+ parseArgs False False False (depth - 1) argsRev (current <> TB.singleton ch) rest+ | ch == ')' && depth == 0 ->+ let arg = trimSpacesText (builderToText current)+ argsRev' =+ if T.null arg && null argsRev+ then [""]+ else arg : argsRev+ in Just (reverse argsRev', rest)+ | ch == ',' && depth == 0 ->+ let arg = trimSpacesText (builderToText current)+ in parseArgs False False False depth (arg : argsRev) mempty rest+ | ch == '-' && depth == 0,+ Just ('-', afterDash) <- T.uncons rest ->+ -- Haskell line comment inside arg list: close the arg, find ')' in comment+ let commentText = "--" <> afterDash+ in case findLastCloseParen commentText of+ Nothing -> Nothing+ Just (commentPrefix, afterClose) ->+ let currentText = builderToText current+ arg = trimSpacesText currentText+ trailingWS = T.takeWhileEnd isSpace currentText+ argsRev' = if T.null arg && null argsRev then [""] else arg : argsRev+ in Just (reverse argsRev', trailingWS <> commentPrefix <> afterClose)+ | otherwise ->+ parseArgs False False False depth argsRev (current <> TB.singleton ch) rest++-- | Find the last ')' in text and split before it.+findLastCloseParen :: Text -> Maybe (Text, Text)+findLastCloseParen txt =+ case T.findIndex (== ')') (T.reverse txt) of+ Nothing -> Nothing+ Just revIdx ->+ let idx = T.length txt - revIdx - 1+ in Just (T.take idx txt, T.drop (idx + 1) txt)++startsHsBlockComment :: Text -> Bool+startsHsBlockComment txt =+ case T.uncons txt of+ Just ('{', rest) ->+ case T.uncons rest of+ Just ('-', rest') ->+ case T.uncons rest' of+ Just ('#', _) -> False+ _ -> True+ _ -> False+ _ -> False++consumeHsBlockComment :: Text -> (Text, Text)+consumeHsBlockComment = go 0 mempty+ where+ go :: Int -> TB.Builder -> Text -> (Text, Text)+ go depth acc txt =+ case T.uncons txt of+ Nothing -> (builderToText acc, "")+ Just (c, rest) ->+ case T.uncons rest of+ Just ('-', rest')+ | c == '{' ->+ go (depth + 1) (acc <> TB.fromText "{-") rest'+ Just ('}', rest')+ | c == '-' && depth <= 1 ->+ (builderToText (acc <> TB.fromText "-}"), rest')+ Just ('}', rest')+ | c == '-' ->+ go (depth - 1) (acc <> TB.fromText "-}") rest'+ _ ->+ go depth (acc <> TB.singleton c) rest++data Piece+ = PieceWhitespace !Text+ | PiecePaste+ | PieceRaw !Text+ | PieceParam !Text++substituteParams :: Map Text Text -> Text -> Text+substituteParams = substituteParamsBuilder++-- | Builder-based parameter substitution. Replaces identifiers found+-- in the substitution map, respecting string and char literals.+substituteParamsBuilder :: Map Text Text -> Text -> Text+substituteParamsBuilder subs = renderPieces . collapseTokenPastes . collapseStringizing . tokenizeReplacementList+ where+ tokenizeReplacementList :: Text -> [Piece]+ tokenizeReplacementList txt =+ case T.uncons txt of+ Nothing -> []+ Just (c, rest)+ | isSpace c ->+ let (spaces, remaining) = T.span isSpace txt+ in PieceWhitespace spaces : tokenizeReplacementList remaining+ | c == '"' ->+ let (literal, remaining) = scanQuoted '"' txt+ in PieceRaw literal : tokenizeReplacementList remaining+ | c == '\'' ->+ let (literal, remaining) = scanQuoted '\'' txt+ in PieceRaw literal : tokenizeReplacementList remaining+ | "/*" `T.isPrefixOf` txt ->+ let (commentText, remaining) = consumeCBlockComment txt+ piece = if commentText == "/**/" then PiecePaste else PieceWhitespace (commentReplacement commentText)+ in piece : tokenizeReplacementList remaining+ | "##" `T.isPrefixOf` txt ->+ PiecePaste : tokenizeReplacementList (T.drop 2 txt)+ | isIdentStart c ->+ let (ident, remaining) = T.span isIdentChar txt+ piece = if M.member ident subs then PieceParam ident else PieceRaw ident+ in piece : tokenizeReplacementList remaining+ | otherwise ->+ PieceRaw (T.singleton c) : tokenizeReplacementList rest++ scanQuoted :: Char -> Text -> (Text, Text)+ scanQuoted quote = go False mempty+ where+ go escaped acc remaining =+ case T.uncons remaining of+ Nothing -> (builderToText acc, "")+ Just (c, rest)+ | c == quote && not escaped ->+ (builderToText (acc <> TB.singleton c), rest)+ | c == '\\' ->+ go (not escaped) (acc <> TB.singleton c) rest+ | otherwise ->+ go False (acc <> TB.singleton c) rest++ collapseStringizing :: [Piece] -> [Piece]+ collapseStringizing [] = []+ collapseStringizing (PieceRaw "#" : PieceParam name : rest) =+ PieceRaw (stringizeArgument (lookupParam name)) : collapseStringizing rest+ collapseStringizing (PieceRaw "#" : rest) =+ PieceRaw "#" : collapseStringizing rest+ collapseStringizing (piece : rest) = piece : collapseStringizing rest++ collapseTokenPastes :: [Piece] -> [Piece]+ collapseTokenPastes = go []+ where+ go acc [] = acc+ go acc (piece : rest) =+ case piece of+ PiecePaste ->+ let (accNoSpace, _) = trimTrailingWhitespace acc+ (leadingSpace, restAfterSpace) = span isWhitespacePiece rest+ in case (unsnoc accNoSpace, restAfterSpace) of+ (Just (accInit, leftPiece), rightPiece : remaining) ->+ go (accInit <> [PieceRaw (renderPiece leftPiece <> renderPiece rightPiece)]) remaining+ _ -> go (acc <> [PieceRaw "##"] <> leadingSpace) restAfterSpace+ _ -> go (acc <> [piece]) rest++ trimTrailingWhitespace :: [Piece] -> ([Piece], [Piece])+ trimTrailingWhitespace pieces =+ let (trailingRev, restRev) = span isWhitespacePiece (reverse pieces)+ in (reverse restRev, reverse trailingRev)++ unsnoc :: [a] -> Maybe ([a], a)+ unsnoc [] = Nothing+ unsnoc [x] = Just ([], x)+ unsnoc (x : xs) = do+ (init', last') <- unsnoc xs+ pure (x : init', last')++ isWhitespacePiece :: Piece -> Bool+ isWhitespacePiece (PieceWhitespace _) = True+ isWhitespacePiece _ = False++ lookupParam :: Text -> Text+ lookupParam name = M.findWithDefault name name subs++ renderPieces :: [Piece] -> Text+ renderPieces = T.concat . map renderPiece++ renderPiece :: Piece -> Text+ renderPiece piece =+ case piece of+ PieceWhitespace txt -> txt+ PiecePaste -> "##"+ PieceRaw txt -> txt+ PieceParam name -> lookupParam name++ stringizeArgument :: Text -> Text+ stringizeArgument arg =+ let normalized = normalizeWhitespace arg+ escaped = T.concatMap escapeStringChar normalized+ in T.cons '"' (T.snoc escaped '"')++ normalizeWhitespace :: Text -> Text+ normalizeWhitespace = T.unwords . T.words++ escapeStringChar :: Char -> Text+ escapeStringChar '"' = "\\\""+ escapeStringChar '\\' = "\\\\"+ escapeStringChar c = T.singleton c++evalCondition :: EngineState -> Text -> Bool+evalCondition st expr = eval expr /= 0+ where+ macros = stMacros st+ eval = evalNumeric . replaceRemainingWithZero . expandMacros st . replaceDefined macros++evalNumeric :: Text -> Integer+evalNumeric input =+ let tokens = tokenize input+ in case parseExpr tokens of+ (val, _) -> val++data Token = TOp Text | TNum Integer | TIdent Text | TOpenParen | TCloseParen deriving (Show)++tokenize :: Text -> [Token]+tokenize input =+ case T.uncons input of+ Nothing -> []+ Just (c, rest)+ | isSpace c ->+ tokenize (T.dropWhile isSpace rest)+ | isDigit c ->+ let (num, remaining) = T.span isDigit input+ in case TR.decimal num of+ Right (value, _) -> TNum value : tokenize remaining+ Left _ -> tokenize remaining+ | isIdentStart c ->+ let (ident, remaining) = T.span isIdentChar input+ in TIdent ident : tokenize remaining+ | c == '(' ->+ TOpenParen : tokenize rest+ | c == ')' ->+ TCloseParen : tokenize rest+ | otherwise ->+ let (op, remaining) = T.span isOpChar input+ in if T.null op+ then tokenize rest+ else TOp op : tokenize remaining++parseExpr :: [Token] -> (Integer, [Token])+parseExpr = parseOr++binary :: ([Token] -> (Integer, [Token])) -> [Text] -> [Token] -> (Integer, [Token])+binary next ops ts =+ let (v1, ts1) = next ts+ in go v1 ts1+ where+ go v1 (TOp op : ts2)+ | op `elem` ops =+ let (v2, ts3) = next ts2+ in go (apply op v1 v2) ts3+ go v1 ts2 = (v1, ts2)++ apply "||" a b = if a /= 0 || b /= 0 then 1 else 0+ apply "&&" a b = if a /= 0 && b /= 0 then 1 else 0+ apply "==" a b = if a == b then 1 else 0+ apply "!=" a b = if a /= b then 1 else 0+ apply "<" a b = if a < b then 1 else 0+ apply ">" a b = if a > b then 1 else 0+ apply "<=" a b = if a <= b then 1 else 0+ apply ">=" a b = if a >= b then 1 else 0+ apply "+" a b = a + b+ apply "-" a b = a - b+ apply "*" a b = a * b+ apply "/" a b = if b == 0 then 0 else a `div` b+ apply "%" a b = if b == 0 then 0 else a `mod` b+ apply _ a _ = a++parseOr, parseAnd, parseEq, parseRel, parseAdd, parseMul :: [Token] -> (Integer, [Token])+parseOr = binary parseAnd ["||"]+parseAnd = binary parseEq ["&&"]+parseEq = binary parseRel ["==", "!="]+parseRel = binary parseAdd ["<", ">", "<=", ">="]+parseAdd = binary parseMul ["+", "-"]+parseMul = binary parseUnary ["*", "/", "%"]++parseUnary :: [Token] -> (Integer, [Token])+parseUnary (TOp "!" : ts) = let (v, ts') = parseUnary ts in (if v == 0 then 1 else 0, ts')+parseUnary (TOp "-" : ts) = let (v, ts') = parseUnary ts in (-v, ts')+parseUnary ts = parseAtom ts++parseAtom :: [Token] -> (Integer, [Token])+parseAtom (TNum n : ts) = (n, ts)+parseAtom (TIdent _ : ts) = (0, ts)+parseAtom (TOpenParen : ts) =+ let (v, ts1) = parseExpr ts+ in case ts1 of+ TCloseParen : ts2 -> (v, ts2)+ _ -> (v, ts1)+parseAtom ts = (0, ts)++replaceDefined :: Map Text MacroDef -> Text -> Text+replaceDefined macros = go+ where+ go txt =+ case T.uncons txt of+ Nothing -> ""+ Just (c, rest)+ | "defined" `T.isPrefixOf` txt && not (nextCharIsIdent (T.drop 7 txt)) ->+ expandDefined (T.dropWhile isSpace (T.drop 7 txt))+ | otherwise ->+ T.cons c (go rest)++ expandDefined rest =+ case T.uncons rest of+ Just ('(', restAfterOpen) ->+ let rest' = T.dropWhile isSpace restAfterOpen+ (name, restAfterName0) = T.span isIdentChar rest'+ restAfterName = T.dropWhile isSpace restAfterName0+ in case T.uncons restAfterName of+ Just (')', restAfterClose) ->+ boolLiteral (M.member name macros) <> go restAfterClose+ _ ->+ boolLiteral False <> go restAfterName+ _ ->+ let (name, restAfterName) = T.span isIdentChar rest+ in if T.null name+ then boolLiteral False <> go rest+ else boolLiteral (M.member name macros) <> go restAfterName++ boolLiteral True = " 1 "+ boolLiteral False = " 0 "++ nextCharIsIdent remaining =+ case T.uncons remaining of+ Just (c, _) -> isIdentChar c+ Nothing -> False++replaceRemainingWithZero :: Text -> Text+replaceRemainingWithZero = go+ where+ go txt =+ case T.uncons txt of+ Nothing -> ""+ Just (c, rest)+ | isIdentStart c ->+ let (_, remaining) = T.span isIdentChar txt+ in " 0 " <> go remaining+ | otherwise ->+ T.cons c (go rest)++builderToText :: TB.Builder -> Text+builderToText = TL.toStrict . TB.toLazyText++trimSpacesText :: Text -> Text+trimSpacesText = T.dropWhileEnd isSpace . T.dropWhile isSpace
+ src/Aihc/Cpp/Parser.hs view
@@ -0,0 +1,164 @@+{-# LANGUAGE OverloadedStrings #-}++module Aihc.Cpp.Parser+ ( Directive (..),+ parseDirective,+ parseDirectiveBody,+ parseDefine,+ parseInclude,+ parseLineDirective,+ parseIdentifier,+ parseQuotedText,+ parseDefineParams,+ isIdentStart,+ isIdentChar,+ isOpChar,+ )+where++import Aihc.Cpp.Types (IncludeKind (..))+import Data.Char (isAlphaNum, isDigit, isLetter)+import Data.Text (Text)+import qualified Data.Text as T+import qualified Data.Text.Read as TR++data Directive+ = DirDefineObject !Text !Text+ | DirDefineFunction !Text ![Text] !Text+ | DirUndef !Text+ | DirInclude !IncludeKind !Text+ | DirIf !Text+ | DirIfDef !Text+ | DirIfNDef !Text+ | DirElif !Text+ | DirElse+ | DirEndIf+ | DirLine !Int !(Maybe FilePath)+ | DirPragmaOnce+ | DirWarning !Text+ | DirError !Text+ | DirUnsupported !Text++parseDirective :: Text -> Maybe Directive+parseDirective raw =+ let trimmed = T.stripStart raw+ in if "#" `T.isPrefixOf` trimmed+ then+ let body = T.stripStart (T.drop 1 trimmed)+ in case T.uncons body of+ Just (c, _) | isLetter c || isDigit c -> parseDirectiveBody body+ _ -> Nothing+ else Nothing++parseDirectiveBody :: Text -> Maybe Directive+parseDirectiveBody body =+ let (name, rest0) = T.span isIdentChar body+ rest = T.stripStart rest0+ in if T.null name+ then case T.uncons body of+ Just (c, _) | isDigit c -> parseLineDirective body+ _ -> Nothing+ else case name of+ "define" -> parseDefine rest+ "undef" -> DirUndef <$> parseIdentifier rest+ "include" -> parseInclude rest+ "if" -> Just (DirIf rest)+ "ifdef" -> DirIfDef <$> parseIdentifier rest+ "ifndef" -> DirIfNDef <$> parseIdentifier rest+ -- Keep `#isndef` as explicitly unsupported for diagnostics on common typo input.+ "isndef" -> Just (DirUnsupported "isndef")+ "elif" -> Just (DirElif rest)+ "elseif" -> Just (DirElif rest)+ "else" -> Just DirElse+ "endif" -> Just DirEndIf+ "line" -> parseLineDirective rest+ "pragma" -> parsePragma rest+ "warning" -> Just (DirWarning rest)+ "error" -> Just (DirError rest)+ _ -> Nothing++parseLineDirective :: Text -> Maybe Directive+parseLineDirective body =+ case TR.decimal body of+ Left _ -> Nothing+ Right (lineNumber, rest0) ->+ let rest = T.stripStart rest0+ in case parseQuotedText rest of+ Nothing -> Just (DirLine lineNumber Nothing)+ Just path -> Just (DirLine lineNumber (Just (T.unpack path)))++parsePragma :: Text -> Maybe Directive+parsePragma body =+ case T.words body of+ ["once"] -> Just DirPragmaOnce+ _ -> Nothing++parseDefine :: Text -> Maybe Directive+parseDefine rest = do+ let (name, rest0) = T.span isIdentChar rest+ if T.null name+ then Nothing+ else case T.uncons rest0 of+ Just ('(', afterOpen) ->+ let (params, restAfterParams) = parseDefineParams afterOpen+ in case params of+ Nothing -> Just (DirUnsupported "define-function-macro")+ Just names -> Just (DirDefineFunction name names (T.stripStart restAfterParams))+ _ -> Just (DirDefineObject name (T.stripStart rest0))++parseDefineParams :: Text -> (Maybe [Text], Text)+parseDefineParams input =+ let (inside, suffix) = T.breakOn ")" input+ in if T.null suffix+ then (Nothing, "")+ else+ let rawParams = T.splitOn "," inside+ params = map (T.takeWhile isIdentChar . T.strip) rawParams+ in if T.null (T.strip inside)+ then (Just [], T.drop 1 suffix)+ else+ if any T.null params+ then (Nothing, T.drop 1 suffix)+ else (Just params, T.drop 1 suffix)++parseIdentifier :: Text -> Maybe Text+parseIdentifier txt =+ let ident = T.takeWhile isIdentChar (T.stripStart txt)+ in if T.null ident then Nothing else Just ident++parseInclude :: Text -> Maybe Directive+parseInclude txt =+ case T.uncons (T.stripStart txt) of+ Just ('"', rest) ->+ let (path, suffix) = T.breakOn "\"" rest+ in if T.null suffix then Nothing else Just (DirInclude IncludeLocal path)+ Just ('<', rest) ->+ let (path, suffix) = T.breakOn ">" rest+ in if T.null suffix then Nothing else Just (DirInclude IncludeSystem path)+ _ -> Nothing++parseQuotedText :: Text -> Maybe Text+parseQuotedText txt = do+ ('"', rest) <- T.uncons txt+ let (path, suffix) = T.breakOn "\"" rest+ if T.null suffix then Nothing else Just path++isIdentStart :: Char -> Bool+isIdentStart c = c == '_' || isLetter c++isIdentChar :: Char -> Bool+isIdentChar c = c == '_' || isAlphaNum c++isOpChar :: Char -> Bool+isOpChar c =+ c == '+'+ || c == '-'+ || c == '*'+ || c == '/'+ || c == '%'+ || c == '&'+ || c == '|'+ || c == '!'+ || c == '='+ || c == '<'+ || c == '>'
+ src/Aihc/Cpp/Scanner.hs view
@@ -0,0 +1,388 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE OverloadedStrings #-}++module Aihc.Cpp.Scanner+ ( LineSpan (..),+ LineScan (..),+ scanLine,+ scanLineDepthOnly,+ expandLineBySpanMultiline,+ )+where++import Aihc.Cpp.Cursor+ ( Cursor (..),+ advance,+ advance2,+ bufLength,+ findNewline,+ null,+ peekByte,+ peekByte2,+ skipNewline,+ skipToInteresting,+ sliceText,+ )+import Aihc.Cpp.Evaluator (expandMacros, expandMacrosMultiline)+import Aihc.Cpp.Types (EngineState)+import Data.Text (Text)+import qualified Data.Text as T+import Prelude hiding (null)++data LineSpan = LineSpan+ { lineSpanInBlockComment :: !Bool,+ lineSpanText :: !Text+ }++data LineScan = LineScan+ { lineScanSpans :: ![LineSpan],+ lineScanFinalHsDepth :: !Int,+ lineScanFinalCDepth :: !Int+ }++-- | Expand macros in a list of line spans (single-line, no lookahead).+expandLineBySpan :: EngineState -> [LineSpan] -> Text+expandLineBySpan st =+ T.concat . map expandSpan+ where+ expandSpan lineChunk+ | lineSpanInBlockComment lineChunk = lineSpanText lineChunk+ | otherwise = expandMacros st (lineSpanText lineChunk)++-- | Expand macros in a list of line spans with multi-line lookahead.+-- When a function macro call spans multiple lines, continuation lines+-- are consumed from the @futureCursor@ (positioned after the current line).+-- Returns (expanded text, number of extra lines consumed).+--+-- Multi-line expansion is only attempted for lines that consist entirely+-- of code spans (no inline comments). Mixed code/comment lines use+-- single-line expansion to preserve comment span positions.+expandLineBySpanMultiline :: EngineState -> [LineSpan] -> Cursor -> (Text, Int)+expandLineBySpanMultiline st spans futureCursor =+ let commentSpans = filter lineSpanInBlockComment spans+ hasLineComment = any (\s -> "--" `T.isPrefixOf` lineSpanText s) commentSpans+ hasCBlockComment = any (T.all (== ' ') . lineSpanText) commentSpans+ hasHsComment = case commentSpans of+ [] -> False+ _ -> not hasCBlockComment+ in if hasLineComment || hasHsComment+ then -- Haskell comments stay in the token stream, so expand the full line.+ let fullText = T.concat [lineSpanText s | s <- spans]+ in (expandMacros st fullText, 0)+ else+ if hasCBlockComment+ then -- C comments are stripped to spaces, so preserve per-span handling.+ (expandLineBySpan st spans, 0)+ else -- Pure code line: try multi-line expansion+ let codeText = T.concat [lineSpanText s | s <- spans]+ futureCodeLines = cursorToLines futureCursor+ in expandMacrosMultiline st codeText futureCodeLines++-- | Extract lines from a cursor as a lazy list of Text values.+-- Each line is the text up to the next newline (or EOF).+cursorToLines :: Cursor -> [Text]+cursorToLines !cur+ | null cur = []+ | otherwise =+ let eol = findNewline cur+ lineText = sliceText (curPos cur) (curPos eol) cur+ in lineText : maybe [] cursorToLines (skipNewline eol)++-- | Lightweight scan that only tracks block comment depth changes.+-- Does not build 'LineSpan' segments or track string/char literals.+-- Used for inactive conditional branches where only comment depth+-- tracking is needed (no macro expansion or span splitting).+--+-- Accepts a 'Cursor' positioned at the start of the line content.+-- The cursor should be bounded to the line (e.g., via 'lineSlice').+scanLineDepthOnly :: Int -> Int -> Cursor -> (Int, Int)+scanLineDepthOnly = goDepth+ where+ goDepth :: Int -> Int -> Cursor -> (Int, Int)+ goDepth !hsDepth !cDepth !cur+ | null cur = (hsDepth, cDepth)+ | otherwise =+ case peekByte2 cur of+ Nothing ->+ -- One byte left, no two-char sequence possible+ (hsDepth, cDepth)+ Just (b1, b2)+ | cDepth > 0 ->+ if b1 == 0x2A && b2 == 0x2F -- '*/'+ then goDepth hsDepth 0 (advance2 cur)+ else goDepth hsDepth cDepth (advance cur)+ | hsDepth > 0 && b1 == 0x2D && b2 == 0x7D -> -- '-}'+ goDepth (hsDepth - 1) cDepth (advance2 cur)+ | b1 == 0x7B && b2 == 0x2D -> -- '{-'+ let cur' = advance2 cur+ in case peekByte cur' of+ Just 0x23 ->+ -- {-# is a pragma, not a comment+ goDepth hsDepth cDepth (advance cur)+ _ ->+ goDepth (hsDepth + 1) cDepth cur'+ | hsDepth == 0 && b1 == 0x2F && b2 == 0x2A -> -- '/*'+ goDepth hsDepth 1 (advance2 cur)+ | hsDepth == 0 && b1 == 0x2D && b2 == 0x2D -> -- '--' line comment+ (hsDepth, cDepth)+ | otherwise ->+ goDepth hsDepth cDepth (advance cur)++-- | Scan a line, tracking comment depths and splitting into spans that are+-- either inside or outside block comments. Uses a byte-level cursor for+-- efficient scanning instead of character-by-character T.uncons/T.cons.+--+-- Accepts a 'Cursor' positioned at the start of the line content.+-- The cursor should be bounded to the line (e.g., via 'lineSlice').+--+-- The scanner splits the line into 'LineSpan' segments. Each segment is+-- tagged with whether it is inside a block comment. Code spans (outside+-- comments) are zero-copy slices of the UTF-8 encoded input. C89 comment+-- content is replaced with spaces to preserve column alignment.+scanLine :: Int -> Int -> Cursor -> LineScan+scanLine hsDepth0 cDepth0 cursor0 =+ let (spans, finalHsDepth, finalCDepth) =+ go+ hsDepth0+ cDepth0+ False+ False+ False+ []+ (curPos cursor0)+ (hsDepth0 > 0 || cDepth0 > 0)+ cursor0+ in LineScan+ { lineScanSpans = reverse spans,+ lineScanFinalHsDepth = finalHsDepth,+ lineScanFinalCDepth = finalCDepth+ }+ where+ -- \| Emit a span from @start@ to @end@ if non-empty, prepending to @acc@.+ emit :: [LineSpan] -> Int -> Int -> Cursor -> Bool -> [LineSpan]+ emit acc start end cur inComment+ | start >= end = acc+ | otherwise = LineSpan inComment (sliceText start end cur) : acc+ {-# INLINE emit #-}++ go ::+ Int ->+ Int ->+ Bool ->+ Bool ->+ Bool ->+ [LineSpan] ->+ Int ->+ Bool ->+ Cursor ->+ ([LineSpan], Int, Int)+ go+ !hsDepth+ !cDepth+ !inString+ !inChar+ !escaped+ !acc+ !spanStart+ !spanInComment+ !cur+ -- End of input: flush the accumulated span+ | null cur =+ (emit acc spanStart (curPos cur) cur spanInComment, hsDepth, cDepth)+ | otherwise =+ case peekByte2 cur of+ Nothing ->+ -- === Only one byte left ===+ if cDepth > 0+ then+ -- In C comment: flush accumulated, emit space+ let acc' = emit acc spanStart (curPos cur) cur spanInComment+ in (LineSpan True " " : acc', hsDepth, cDepth)+ else+ -- Include this last byte in the accumulated span+ let inCommentNow = hsDepth > 0+ cur' = advance cur+ in (emit acc spanStart (curPos cur') cur inCommentNow, hsDepth, cDepth)+ Just (b1, b2) ->+ -- === C block comment mode ===+ if cDepth > 0+ then+ if b1 == 0x2A && b2 == 0x2F -- '*/'+ then+ let acc' = emit acc spanStart (curPos cur) cur spanInComment+ cur' = advance2 cur+ in go+ hsDepth+ 0+ False+ False+ False+ (LineSpan True " " : acc')+ (curPos cur')+ False+ cur'+ else+ let acc' = emit acc spanStart (curPos cur) cur spanInComment+ cur' = advance cur+ in go+ hsDepth+ cDepth+ False+ False+ False+ (LineSpan True " " : acc')+ (curPos cur')+ True+ cur'+ -- === Line comment: -- (outside strings and hs comments) ===+ else+ if not inString+ && not inChar+ && hsDepth == 0+ && b1 == 0x2D+ && b2 == 0x2D -- '--'+ then+ let acc' = emit acc spanStart (curPos cur) cur spanInComment+ restText = sliceText (curPos cur) (bufLength cur) cur+ in (LineSpan True restText : acc', hsDepth, cDepth)+ -- === Inside string literal ===+ else+ if inString+ then+ let escaped' = not escaped && b1 == 0x5C -- '\\'+ inString' = escaped || b1 /= 0x22 -- '"'+ in go+ hsDepth+ cDepth+ inString'+ False+ escaped'+ acc+ spanStart+ spanInComment+ (advance cur)+ -- === Inside char literal ===+ else+ if inChar+ then+ let escaped' = not escaped && b1 == 0x5C -- '\\'+ inChar' = escaped || b1 /= 0x27 -- '\''+ in go+ hsDepth+ cDepth+ False+ inChar'+ escaped'+ acc+ spanStart+ spanInComment+ (advance cur)+ -- === Start of string literal ===+ else+ if hsDepth == 0 && b1 == 0x22 -- '"'+ then+ go+ hsDepth+ cDepth+ True+ False+ False+ acc+ spanStart+ spanInComment+ (advance cur)+ -- === Start of char literal ===+ else+ if hsDepth == 0 && b1 == 0x27 -- '\''+ then+ go+ hsDepth+ cDepth+ False+ True+ False+ acc+ spanStart+ spanInComment+ (advance cur)+ -- === End of Haskell block comment: -} ===+ else+ if hsDepth > 0 && b1 == 0x2D && b2 == 0x7D -- '-}'+ then+ let cur' = advance2 cur+ hsDepth' = hsDepth - 1+ -- Flush everything up to and including -} as a comment span+ acc' = emit acc spanStart (curPos cur') cur True+ inCommentAfter = hsDepth' > 0+ in go+ hsDepth'+ cDepth+ False+ False+ False+ acc'+ (curPos cur')+ inCommentAfter+ cur'+ -- === Start of Haskell block comment: {- (but not {-#) ===+ else+ if b1 == 0x7B && b2 == 0x2D -- '{-'+ then+ let cur' = advance2 cur+ in case peekByte cur' of+ Just 0x23 ->+ -- '#' => pragma {-#, not a block comment+ -- Advance past '{' only, continue in same mode+ go+ hsDepth+ cDepth+ False+ False+ False+ acc+ spanStart+ spanInComment+ (advance cur)+ _ ->+ -- Flush any text before {-, emit {- as comment+ let acc' = emit acc spanStart (curPos cur) cur spanInComment+ acc'' = LineSpan True "{-" : acc'+ in go+ (hsDepth + 1)+ cDepth+ False+ False+ False+ acc''+ (curPos cur')+ True+ cur'+ -- === Start of C block comment: /* ===+ else+ if hsDepth == 0 && b1 == 0x2F && b2 == 0x2A -- '/*'+ then+ let acc' = emit acc spanStart (curPos cur) cur spanInComment+ cur' = advance2 cur+ in go+ hsDepth+ 1+ False+ False+ False+ (LineSpan True " " : acc')+ (curPos cur')+ True+ cur'+ -- === Normal byte: bulk-skip non-interesting bytes ===+ else+ let cur' = skipToInteresting (advance cur)+ in go+ hsDepth+ cDepth+ False+ False+ False+ acc+ spanStart+ spanInComment+ cur'
+ src/Aihc/Cpp/Types.hs view
@@ -0,0 +1,197 @@+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE OverloadedStrings #-}++module Aihc.Cpp.Types+ ( Config (..),+ MacroDef (..),+ defaultConfig,+ IncludeKind (..),+ IncludeRequest (..),+ Severity (..),+ Diagnostic (..),+ Result (..),+ Step (..),+ EngineState (..),+ emptyState,+ CondFrame (..),+ currentActive,+ mkFrame,+ Continuation,+ LineContext (..),+ )+where++import Aihc.Cpp.Cursor (Cursor)+import Control.DeepSeq (NFData)+import Data.ByteString (ByteString)+import Data.Map.Strict (Map)+import qualified Data.Map.Strict as M+import Data.Set (Set)+import qualified Data.Set as S+import Data.Text (Text)+import qualified Data.Text.Lazy.Builder as TB+import GHC.Generics (Generic)++-- $setup+-- >>> :set -XOverloadedStrings+-- >>> import qualified Data.Map.Strict as M++-- | Configuration for the C preprocessor.+data Config = Config+ { -- | The name of the input file, used in @#line@ directives and+ -- @__FILE__@ expansion.+ configInputFile :: FilePath,+ -- | User-defined macros. These are expanded as object-like macros.+ -- Note that the values should include any necessary quoting. For+ -- example, to define a string macro, use @"\"value\""@.+ configMacros :: !(Map Text Text)+ }++data MacroDef+ = ObjectMacro !Text+ | FunctionMacro ![Text] !Text+ deriving (Eq, Show)++-- | Default configuration with sensible defaults.+--+-- * 'configInputFile' is set to @\"\<input\>\"@+-- * 'configMacros' includes @__DATE__@ and @__TIME__@ set to the Unix epoch+--+-- To customize the date and time macros:+--+-- >>> import qualified Data.Map.Strict as M+-- >>> let cfg = defaultConfig { configMacros = M.fromList [("__DATE__", "\"Mar 15 2026\""), ("__TIME__", "\"14:30:00\"")] }+-- >>> configMacros cfg+-- fromList [("__DATE__","\"Mar 15 2026\""),("__TIME__","\"14:30:00\"")]+--+-- To add additional macros while keeping the defaults:+--+-- >>> import qualified Data.Map.Strict as M+-- >>> let cfg = defaultConfig { configMacros = M.insert "VERSION" "42" (configMacros defaultConfig) }+-- >>> M.lookup "VERSION" (configMacros cfg)+-- Just "42"+defaultConfig :: Config+defaultConfig =+ Config+ { configInputFile = "<input>",+ configMacros =+ M.fromList+ [ ("__DATE__", "\"Jan 1 1970\""),+ ("__TIME__", "\"00:00:00\"")+ ]+ }++-- | The kind of @#include@ directive.+data IncludeKind = IncludeLocal | IncludeSystem deriving (Eq, Show, Generic, NFData)++-- | Information about a pending @#include@ that needs to be resolved.+data IncludeRequest = IncludeRequest+ { -- | The path specified in the include directive.+ includePath :: !FilePath,+ -- | Whether this is a local (@\"...\"@) or system (@\<...\>@) include.+ includeKind :: !IncludeKind,+ -- | The file that contains the @#include@ directive.+ includeFrom :: !FilePath,+ -- | The line number of the @#include@ directive.+ includeLine :: !Int+ }+ deriving (Eq, Show, Generic, NFData)++-- | Severity level for diagnostics.+data Severity = Warning | Error deriving (Eq, Show, Generic, NFData)++-- | A diagnostic message emitted during preprocessing.+data Diagnostic = Diagnostic+ { -- | The severity of the diagnostic.+ diagSeverity :: !Severity,+ -- | The diagnostic message text.+ diagMessage :: !Text,+ -- | The file where the diagnostic occurred.+ diagFile :: !FilePath,+ -- | The line number where the diagnostic occurred.+ diagLine :: !Int+ }+ deriving (Eq, Show, Generic, NFData)++-- | The result of preprocessing.+data Result = Result+ { -- | The preprocessed output text.+ resultOutput :: !Text,+ -- | Any diagnostics (warnings or errors) emitted during preprocessing.+ resultDiagnostics :: ![Diagnostic]+ }+ deriving (Eq, Show, Generic, NFData)++-- | A step in the preprocessing process. Either preprocessing is complete+-- ('Done') or an @#include@ directive needs to be resolved ('NeedInclude').+data Step+ = -- | Preprocessing is complete.+ Done !Result+ | -- | An @#include@ directive was encountered. The caller must provide+ -- the contents of the included file (or 'Nothing' if not found),+ -- and preprocessing will continue.+ NeedInclude !IncludeRequest !(Maybe ByteString -> Step)++data EngineState = EngineState+ { stMacros :: !(Map Text MacroDef),+ stOutput :: !TB.Builder,+ stOutputLineCount :: {-# UNPACK #-} !Int,+ stDiagnosticsRev :: ![Diagnostic],+ stPragmaOnceFiles :: !(Set FilePath),+ stSkippingDanglingElse :: !Bool,+ stHsBlockCommentDepth :: !Int,+ stCBlockCommentDepth :: !Int,+ stCurrentFile :: !FilePath,+ stCurrentLine :: !Int+ }++emptyState :: FilePath -> EngineState+emptyState filePath =+ EngineState+ { stMacros = M.empty,+ stOutput = mempty,+ stOutputLineCount = 0,+ stDiagnosticsRev = [],+ stPragmaOnceFiles = S.empty,+ stSkippingDanglingElse = False,+ stHsBlockCommentDepth = 0,+ stCBlockCommentDepth = 0,+ stCurrentFile = filePath,+ stCurrentLine = 1+ }++data CondFrame = CondFrame+ { frameOuterActive :: !Bool,+ frameConditionTrue :: !Bool,+ frameInElse :: !Bool,+ frameCurrentActive :: !Bool+ }++currentActive :: [CondFrame] -> Bool+currentActive [] = True+currentActive (f : _) = frameCurrentActive f++mkFrame :: Bool -> Bool -> CondFrame+mkFrame outer cond =+ CondFrame+ { frameOuterActive = outer,+ frameConditionTrue = cond,+ frameInElse = False,+ frameCurrentActive = outer && cond+ }++type Continuation = EngineState -> Step++data LineContext = LineContext+ { lcFilePath :: !FilePath,+ lcLineNo :: !Int,+ lcLineSpan :: !Int,+ lcNextLineNo :: !Int,+ -- | Cursor positioned after the current line (past its newline).+ lcRestCursor :: !Cursor,+ lcStack :: ![CondFrame],+ lcContinue :: EngineState -> Step,+ lcContinueWith :: [CondFrame] -> EngineState -> Step,+ lcDone :: Continuation+ }
+ test/Spec.hs view
@@ -0,0 +1,330 @@+{-# LANGUAGE OverloadedStrings #-}++module Main (main) where++import Aihc.Cpp (Config (..), Result (..), Step (..), defaultConfig, preprocess)+import qualified Data.Map.Strict as M+import qualified Data.Text as T+import qualified Data.Text.Encoding as TE+import Test.Progress (CaseMeta (..), Outcome (..), evaluateCase, loadManifest)+import Test.Tasty (TestTree, defaultMain, testGroup)+import Test.Tasty.HUnit (Assertion, assertFailure, testCase)+import qualified Test.Tasty.QuickCheck as QC++main :: IO ()+main = do+ cases <- loadManifest+ checks <- mapM mkCase cases+ defaultMain+ ( testGroup+ "cpp-oracle"+ ( checks+ <> [linePragmaTest, dateTimeTest, functionMacroArgumentTest, functionMacroUnclosedCallTest, definedConditionSpacingTest, stringContinuationTests, tokenPastingTests, ccallLineCommentTest]+ <> [pragmaOnceTest]+ <> [QC.testProperty "dummy quickcheck property" prop_dummy]+ )+ )++-- | Dummy QuickCheck property that always passes.+-- Added so that --quickcheck-tests flag is accepted by the test suite.+prop_dummy :: Bool+prop_dummy = True++dateTimeTest :: TestTree+dateTimeTest =+ testGroup+ "__DATE__ and __TIME__"+ [ testCase "expands to provided values" $ do+ let cfg =+ defaultConfig+ { configMacros =+ M.fromList+ [ ("__DATE__", "\"Mar 15 2026\""),+ ("__TIME__", "\"12:00:00\"")+ ]+ }+ input = TE.encodeUtf8 "__DATE__ __TIME__"+ case preprocess cfg input of+ Done result ->+ resultOutput result @?= "#line 1 \"<input>\"\n\"Mar 15 2026\" \"12:00:00\"\n"+ _ -> assertFailure "expected Done",+ testCase "defaults to unix epoch" $ do+ let cfg = defaultConfig+ input = TE.encodeUtf8 "__DATE__ __TIME__"+ case preprocess cfg input of+ Done result ->+ resultOutput result @?= "#line 1 \"<input>\"\n\"Jan 1 1970\" \"00:00:00\"\n"+ _ -> assertFailure "expected Done"+ ]++(@?=) :: (Eq a, Show a) => a -> a -> Assertion+actual @?= expected =+ if actual == expected+ then pure ()+ else assertFailure ("expected: " <> show expected <> "\n but got: " <> show actual)++mkCase :: CaseMeta -> IO TestTree+mkCase meta =+ pure $ testCase (caseId meta) (assertCase meta)++assertCase :: CaseMeta -> Assertion+assertCase meta = do+ (_, outcome, details) <- evaluateCase meta+ case outcome of+ OutcomeFail ->+ assertFailure+ ( "cpp regression in "+ <> caseId meta+ <> " ["+ <> caseCategory meta+ <> "]: "+ <> details+ )+ _ -> pure ()++linePragmaTest :: TestTree+linePragmaTest =+ testCase "include emits line pragmas" $+ case preprocess defaultConfig {configInputFile = "root.hs"} (TE.encodeUtf8 "before\n#include \"nested.inc\"\nafter") of+ NeedInclude _ k ->+ case k (Just "inside") of+ Done result -> do+ let out = T.lines (resultOutput result)+ hasIncludePragma = any (T.isSuffixOf "nested.inc\"") out+ if hasIncludePragma && "#line 3 \"root.hs\"" `elem` out+ then pure ()+ else assertFailure "expected include line pragmas in output"+ NeedInclude {} -> assertFailure "unexpected nested include in line pragma test"+ Done _ -> assertFailure "expected include continuation step"++functionMacroArgumentTest :: TestTree+functionMacroArgumentTest =+ testCase "function-like macro keeps nested argument text" $+ case preprocess defaultConfig (TE.encodeUtf8 "#define PAIR(x,y) x + y\nPAIR((1 + 2), 3)") of+ Done result ->+ resultOutput result @?= "#line 1 \"<input>\"\n\n(1 + 2) + 3\n"+ _ -> assertFailure "expected Done"++functionMacroUnclosedCallTest :: TestTree+functionMacroUnclosedCallTest =+ testCase "unterminated function-like call does not expand macro" $+ case preprocess defaultConfig (TE.encodeUtf8 "#define ID() replaced\nID(") of+ Done result ->+ resultOutput result @?= "#line 1 \"<input>\"\n\nID(\n"+ _ -> assertFailure "expected Done"++definedConditionSpacingTest :: TestTree+definedConditionSpacingTest =+ testCase "defined handles whitespace around parenthesized name" $+ case preprocess defaultConfig (TE.encodeUtf8 "#define FLAG 1\n#if defined ( FLAG )\nok\n#else\nbad\n#endif") of+ Done result ->+ if "ok\n" `T.isInfixOf` resultOutput result && not ("bad\n" `T.isInfixOf` resultOutput result)+ then pure ()+ else assertFailure ("expected ok branch to be active, output was: " <> show (resultOutput result))+ _ -> assertFailure "expected Done"++stringContinuationTests :: TestTree+stringContinuationTests =+ testGroup+ "Haskell string continuations"+ [ testCase "ordinary string accepts GCC double-backslash continuation" $+ assertPreprocessOutput+ gccStringContinuationInput+ (T.unlines ["#line 1 \"<input>\"", "x = \"a\\ \\b\""]),+ testCase "ordinary string preserves GHC single-backslash gap" $+ assertPreprocessOutput+ ghcStringGapInput+ (T.unlines ["#line 1 \"<input>\"", "x = \"a\\", " \\b\""]),+ testCase "function macro argument accepts GCC double-backslash continuation" $+ assertPreprocessOutput+ gccStringContinuationMacroInput+ (T.unlines ["#line 1 \"<input>\"", "", "x = \"a\\ \\b\""]),+ testCase "function macro argument preserves GHC single-backslash gap" $+ assertPreprocessOutput+ ghcStringGapMacroInput+ (T.unlines ["#line 1 \"<input>\"", "", "x = \"a\\", " \\b\""]),+ testCase "GCC continuation tracks string gaps across concatenation" $+ assertPreprocessOutput+ gccStringContinuationConcatInput+ (T.unlines ["#line 1 \"<input>\"", "x = \"a\\ \\\" <> y <> \"\\n\\ \\b\""]),+ testCase "double backslash outside strings is not line-spliced" $+ assertPreprocessOutput+ nonStringDoubleBackslashInput+ (T.unlines ["#line 1 \"<input>\"", "", "x = foo \\\\", " bar"])+ ]++assertPreprocessOutput :: T.Text -> T.Text -> Assertion+assertPreprocessOutput input expected =+ case preprocess defaultConfig (TE.encodeUtf8 input) of+ Done result -> resultOutput result @?= expected+ _ -> assertFailure "expected Done"++tokenPastingTests :: TestTree+tokenPastingTests =+ testGroup+ "token pasting"+ [ testCase "CCALL macro expands stringizing and token pasting" $+ case preprocess defaultConfig (TE.encodeUtf8 ccallMacroInput) of+ Done result ->+ if "foreign import ccall unsafe \"foo\"" `T.isInfixOf` resultOutput result+ && "c_foo :: Int -> IO Int" `T.isInfixOf` resultOutput result+ then pure ()+ else assertFailure ("expected CCALL expansion in output, got: " <> show (resultOutput result))+ _ -> assertFailure "expected Done",+ testCase "token pasting joins both sides without expanding arguments first" $+ case preprocess defaultConfig (TE.encodeUtf8 tokenPasteRawArgInput) of+ Done result ->+ resultOutput result @?= "#line 1 \"<input>\"\n\n\nXY\n"+ _ -> assertFailure "expected Done",+ testCase "token pasting result is rescanned for further macro expansion" $+ case preprocess defaultConfig (TE.encodeUtf8 tokenPasteRescanInput) of+ Done result ->+ resultOutput result @?= "#line 1 \"<input>\"\n\n\n42\n"+ _ -> assertFailure "expected Done",+ testCase "token pasting supports prefix and suffix forms" $+ case preprocess defaultConfig (TE.encodeUtf8 tokenPasteAffixInput) of+ Done result ->+ resultOutput result @?= "#line 1 \"<input>\"\n\n\nleft right\n"+ _ -> assertFailure "expected Done",+ testCase "token pasting supports chained concatenation" $+ case preprocess defaultConfig (TE.encodeUtf8 tokenPasteChainedInput) of+ Done result ->+ resultOutput result @?= "#line 1 \"<input>\"\n\nfoobar\n"+ _ -> assertFailure "expected Done",+ testCase "token pasting survives Haskell block comments in arguments" $+ case preprocess defaultConfig (TE.encodeUtf8 tokenPasteHsCommentInput) of+ Done result ->+ resultOutput result+ @?= "#line 1 \"<input>\"\n\n{-# INLINE _bar #-}; _bar :: LensP Foo Baz{-comment-}; _bar = lens bar $ \\ Foo {..} bar_ -> Foo {bar = bar_, ..}\n"+ _ -> assertFailure "expected Done"+ ]++ccallLineCommentTest :: TestTree+ccallLineCommentTest =+ testCase "CCALL macro with -- comment in argument list" $+ case preprocess defaultConfig (TE.encodeUtf8 ccallLineCommentInput) of+ Done result ->+ if "foreign import ccall unsafe \"xls_wb_sheetcount\"" `T.isInfixOf` resultOutput result+ && "c_xls_wb_sheetcount :: XLSWorkbook -> IO CInt" `T.isInfixOf` resultOutput result+ && " -- Int32" `T.isInfixOf` resultOutput result+ then pure ()+ else assertFailure ("expected CCALL expansion with line comment, got: " <> show (resultOutput result))+ _ -> assertFailure "expected Done"++pragmaOnceTest :: TestTree+pragmaOnceTest =+ testCase "#pragma once skips repeated includes" $+ case preprocess defaultConfig {configInputFile = "root.hs"} (TE.encodeUtf8 "#include \"guarded.inc\"\n#include \"guarded.inc\"\nafter") of+ NeedInclude _ k1 ->+ case k1 (Just "#pragma once\ninside") of+ NeedInclude {} -> assertFailure "second include should be skipped"+ Done result -> do+ let output = resultOutput result+ if T.count "inside" output == 1 && "after\n" `T.isSuffixOf` output+ then pure ()+ else assertFailure ("expected guarded include once, got: " <> show output)+ Done _ -> assertFailure "expected include continuation step"++ccallLineCommentInput :: T.Text+ccallLineCommentInput =+ T.unlines+ [ "#define CCALL(name,signature) \\",+ "foreign import ccall unsafe #name \\",+ " c_##name :: signature",+ "",+ "CCALL(xls_wb_sheetcount, XLSWorkbook -> IO CInt -- Int32)"+ ]++ccallMacroInput :: T.Text+ccallMacroInput =+ T.unlines+ [ "#define CCALL(name,signature) \\",+ "foreign import ccall unsafe #name \\",+ " c_##name :: signature",+ "",+ "CCALL(foo, Int -> IO Int)"+ ]++tokenPasteRawArgInput :: T.Text+tokenPasteRawArgInput =+ T.unlines+ [ "#define X Y",+ "#define JOIN(a,b) a##b",+ "JOIN(X,Y)"+ ]++tokenPasteRescanInput :: T.Text+tokenPasteRescanInput =+ T.unlines+ [ "#define VALUE 42",+ "#define JOIN(a,b) a##b",+ "JOIN(VAL,UE)"+ ]++tokenPasteAffixInput :: T.Text+tokenPasteAffixInput =+ T.unlines+ [ "#define PREFIX(name) left##name",+ "#define SUFFIX(name) name##right",+ "PREFIX() SUFFIX()"+ ]++tokenPasteChainedInput :: T.Text+tokenPasteChainedInput =+ T.unlines+ [ "#define CHAIN(a,b,c) a##b##c",+ "CHAIN(foo,bar,)"+ ]++tokenPasteHsCommentInput :: T.Text+tokenPasteHsCommentInput =+ T.unlines+ [ "#define LENS(S,F,A) {-# INLINE _/**/F #-}; _/**/F :: LensP S A; _/**/F = lens F $ \\ S {..} F/**/_ -> S {F = F/**/_, ..}",+ "LENS(Foo,bar,Baz{-comment-})"+ ]++gccStringContinuationInput :: T.Text+gccStringContinuationInput =+ T.unlines+ [ "x = \"a\\\\",+ " \\b\""+ ]++ghcStringGapInput :: T.Text+ghcStringGapInput =+ T.unlines+ [ "x = \"a\\",+ " \\b\""+ ]++gccStringContinuationMacroInput :: T.Text+gccStringContinuationMacroInput =+ T.unlines+ [ "#define ID(x) x",+ "x = ID(\"a\\\\",+ " \\b\")"+ ]++ghcStringGapMacroInput :: T.Text+ghcStringGapMacroInput =+ T.unlines+ [ "#define ID(x) x",+ "x = ID(\"a\\",+ " \\b\")"+ ]++gccStringContinuationConcatInput :: T.Text+gccStringContinuationConcatInput =+ T.unlines+ [ "x = \"a\\\\",+ " \\\" <> y <> \"\\n\\\\",+ " \\b\""+ ]++nonStringDoubleBackslashInput :: T.Text+nonStringDoubleBackslashInput =+ T.unlines+ [ "#define ID(x) x",+ "x = ID(foo \\\\",+ " bar)"+ ]
+ test/Test/Progress.hs view
@@ -0,0 +1,297 @@+{-# LANGUAGE OverloadedStrings #-}++module Test.Progress+ ( CaseMeta (..),+ Outcome (..),+ evaluateCase,+ loadManifest,+ progressSummary,+ )+where++import Aihc.Cpp (Config (..), Diagnostic (..), IncludeRequest (..), Result (..), Severity (..), Step (..), defaultConfig, preprocess)+import qualified Control.Exception as E+import qualified Data.ByteString as BS+import Data.Char (isDigit, isSpace)+import Data.List (dropWhileEnd)+import Data.Maybe (fromMaybe)+import Data.Text (Text)+import qualified Data.Text as T+import qualified Data.Text.IO as TIO+import GHC.IO.Handle (hDuplicate, hDuplicateTo)+import Language.Preprocessor.Cpphs (BoolOptions (..), CpphsOptions (..), defaultCpphsOptions, runCpphs)+import System.Directory (doesFileExist, getTemporaryDirectory, removeFile)+import System.FilePath (takeDirectory, (</>))+import System.IO (IOMode (ReadMode), hClose, hFlush, openTempFile, stderr, withFile)++data Expected = ExpectPass | ExpectXFail deriving (Eq, Show)++data Outcome = OutcomePass | OutcomeXFail | OutcomeXPass | OutcomeFail deriving (Eq, Show)++data CaseMeta = CaseMeta+ { caseId :: !String,+ caseCategory :: !String,+ casePath :: !FilePath,+ caseExpected :: !Expected,+ caseReason :: !String+ }+ deriving (Eq, Show)++fixtureRoot :: FilePath+fixtureRoot = "test/Test/Fixtures/progress"++manifestPath :: FilePath+manifestPath = fixtureRoot </> "manifest.tsv"++progressSummary :: [(CaseMeta, Outcome, String)] -> (Int, Int, Int, Int)+progressSummary outcomes =+ ( count OutcomePass,+ count OutcomeXFail,+ count OutcomeXPass,+ count OutcomeFail+ )+ where+ count wanted = length [() | (_, out, _) <- outcomes, out == wanted]++evaluateCase :: CaseMeta -> IO (CaseMeta, Outcome, String)+evaluateCase meta = do+ let sourcePath = fixtureRoot </> casePath meta+ source <- BS.readFile sourcePath+ ours <- runOurs sourcePath source+ oracle <- runOracle sourcePath+ let (outcome, details) = classify (caseExpected meta) ours oracle+ pure (meta, outcome, details)++classify :: Expected -> Either String Text -> Either String Text -> (Outcome, String)+classify expected ours oracle =+ case expected of+ ExpectPass ->+ case (ours, oracle) of+ (Right oursOut, Right oracleOut) ->+ case compareLocatedOutput oursOut oracleOut of+ Nothing -> (OutcomePass, "")+ Just details -> (OutcomeFail, "preprocessed output differs from cpphs oracle: " <> details)+ (Left _, Left _) -> (OutcomePass, "")+ (Left oursErr, _) -> (OutcomeFail, "ours failed: " <> oursErr)+ (_, Left oracleErr) -> (OutcomeFail, "oracle failed: " <> oracleErr)+ ExpectXFail ->+ case (ours, oracle) of+ (Right oursOut, Right oracleOut) ->+ case compareLocatedOutput oursOut oracleOut of+ Nothing -> (OutcomeXPass, "expected xfail but now matches cpphs")+ Just _ -> (OutcomeXFail, "")+ (Left _, Left _) -> (OutcomeXPass, "expected xfail but now matches cpphs")+ _ -> (OutcomeXFail, "")++data LocatedLine = LocatedLine+ { locatedLineNo :: !Int,+ locatedFile :: !FilePath,+ locatedText :: !Text+ }+ deriving (Eq, Show)++compareLocatedOutput :: Text -> Text -> Maybe String+compareLocatedOutput oursOut oracleOut =+ firstDifference (toLocatedLines oursOut) (toLocatedLines oracleOut)++firstDifference :: [LocatedLine] -> [LocatedLine] -> Maybe String+firstDifference = go (1 :: Int)+ where+ go :: Int -> [LocatedLine] -> [LocatedLine] -> Maybe String+ go _ [] [] = Nothing+ go n (o : os) (r : rs)+ | o == r = go (n + 1) os rs+ | otherwise =+ Just+ ( "first mismatch at output record "+ <> show n+ <> ": ours="+ <> showLocated o+ <> ", oracle="+ <> showLocated r+ )+ go n [] (r : _) =+ Just+ ( "ours ended early at output record "+ <> show n+ <> ", oracle has "+ <> showLocated r+ )+ go n (o : _) [] =+ Just+ ( "oracle ended early at output record "+ <> show n+ <> ", ours has "+ <> showLocated o+ )++showLocated :: LocatedLine -> String+showLocated (LocatedLine ln fp txt) =+ "(" <> show ln <> ", " <> show fp <> ", " <> show (T.unpack txt) <> ")"++toLocatedLines :: Text -> [LocatedLine]+toLocatedLines = go 1 "<unknown>" . T.lines+ where+ go _ _ [] = []+ go lineNo filePath (line : rest) =+ case parseLinePragma line of+ Just (nextLineNo, mFilePath) ->+ let filePath' = fromMaybe filePath mFilePath+ in go nextLineNo filePath' rest+ Nothing ->+ LocatedLine lineNo filePath line : go (lineNo + 1) filePath rest++parseLinePragma :: Text -> Maybe (Int, Maybe FilePath)+parseLinePragma raw =+ let line = T.strip raw+ in case T.stripPrefix "#line" line of+ Nothing -> Nothing+ Just rest0 ->+ let rest1 = T.stripStart rest0+ (lineNoTxt, rest2) = T.span isDigit rest1+ in if T.null lineNoTxt+ then Nothing+ else case reads (T.unpack lineNoTxt) of+ [(lineNo, "")] ->+ let rest3 = T.stripStart rest2+ in if T.null rest3+ then Just (lineNo, Nothing)+ else case T.uncons rest3 of+ Just ('"', quoted) ->+ let (filePath, suffix) = T.breakOn "\"" quoted+ in if T.null suffix+ then Nothing+ else Just (lineNo, Just (T.unpack filePath))+ _ -> Nothing+ _ -> Nothing++runOurs :: FilePath -> BS.ByteString -> IO (Either String Text)+runOurs sourcePath source = do+ result <- drive (preprocess defaultConfig {configInputFile = sourcePath} source)+ let errors = [diagMessage d | d <- resultDiagnostics result, diagSeverity d == Error]+ case errors of+ [] -> pure (Right (resultOutput result))+ (msg : _) -> pure (Left (T.unpack msg))+ where+ drive (Done result) = pure result+ drive (NeedInclude req k) = do+ let includeAbsPath = resolveIncludePath sourcePath req+ exists <- doesFileExist includeAbsPath+ content <- if exists then Just <$> BS.readFile includeAbsPath else pure Nothing+ drive (k content)++resolveIncludePath :: FilePath -> IncludeRequest -> FilePath+resolveIncludePath rootPath req =+ includeBaseDir </> includePath req+ where+ includeFromDir = takeDirectory (includeFrom req)+ includeBaseDir =+ if null includeFromDir+ then takeDirectory rootPath+ else includeFromDir++runOracle :: FilePath -> IO (Either String Text)+runOracle sourcePath = do+ source <- TIO.readFile sourcePath+ let cpphsOptions =+ defaultCpphsOptions+ { boolopts =+ (boolopts defaultCpphsOptions)+ { stripC89 = True,+ warnings = False+ }+ }+ (oracleOut, capturedStderr) <-+ captureStderrText+ ( ( E.try $ do+ out <- runCpphs cpphsOptions sourcePath (T.unpack source)+ _ <- E.evaluate (length out)+ pure out+ ) ::+ IO (Either E.SomeException String)+ )+ pure $+ case oracleOut of+ Right out -> Right (T.pack out)+ Left err ->+ Left+ ( "cpphs failed: "+ <> show err+ <> stderrSuffix capturedStderr+ )++captureStderrText :: IO a -> IO (a, Text)+captureStderrText action = do+ tempDir <- getTemporaryDirectory+ (tempPath, tempHandle) <- openTempFile tempDir "cpphs-stderr.txt"+ originalStderr <- hDuplicate stderr+ let restoreStderr = hFlush stderr >> hDuplicateTo originalStderr stderr+ cleanup = do+ hClose tempHandle+ hClose originalStderr+ removeFile tempPath+ E.bracketOnError+ (pure ())+ (const (restoreStderr >> cleanup))+ $ \() -> do+ hFlush stderr+ hDuplicateTo tempHandle stderr+ result <- action `E.finally` restoreStderr+ hClose tempHandle+ captured <- withFile tempPath ReadMode TIO.hGetContents+ hClose originalStderr+ removeFile tempPath+ pure (result, captured)++stderrSuffix :: Text -> String+stderrSuffix captured+ | T.null stripped = ""+ | otherwise = " stderr=" <> T.unpack stripped+ where+ stripped = T.strip captured++loadManifest :: IO [CaseMeta]+loadManifest = do+ raw <- TIO.readFile manifestPath+ let rows = filter (not . T.null) (map stripComment (T.lines raw))+ mapM parseRow rows++stripComment :: Text -> Text+stripComment line =+ let core = fst (T.breakOn "#" line)+ in T.strip core++parseRow :: Text -> IO CaseMeta+parseRow row =+ case T.splitOn "\t" row of+ [cid, cat, pathTxt, expectedTxt] -> parseRowWithReason cid cat pathTxt expectedTxt ""+ [cid, cat, pathTxt, expectedTxt, reasonTxt] -> parseRowWithReason cid cat pathTxt expectedTxt reasonTxt+ _ -> fail ("Invalid manifest row (expected 4 or 5 tab-separated columns): " <> T.unpack row)++parseRowWithReason :: Text -> Text -> Text -> Text -> Text -> IO CaseMeta+parseRowWithReason cid cat pathTxt expectedTxt reasonTxt = do+ let path = T.unpack pathTxt+ exists <- doesFileExist (fixtureRoot </> path)+ if not exists+ then fail ("Manifest references missing case file: " <> path)+ else do+ expected <-+ case expectedTxt of+ "pass" -> pure ExpectPass+ "xfail" -> pure ExpectXFail+ _ -> fail ("Unknown expected value in manifest: " <> T.unpack expectedTxt)+ let reason = trim (T.unpack reasonTxt)+ case expected of+ ExpectXFail | null reason -> fail ("xfail case requires reason: " <> T.unpack cid)+ _ -> pure ()+ pure+ CaseMeta+ { caseId = T.unpack cid,+ caseCategory = T.unpack cat,+ casePath = path,+ caseExpected = expected,+ caseReason = reason+ }++trim :: String -> String+trim = dropWhile isSpace . dropWhileEnd isSpace