diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -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. diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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 diff --git a/aihc-cpp.cabal b/aihc-cpp.cabal new file mode 100644 --- /dev/null +++ b/aihc-cpp.cabal @@ -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 diff --git a/app/cpp-progress/Main.hs b/app/cpp-progress/Main.hs new file mode 100644 --- /dev/null +++ b/app/cpp-progress/Main.hs @@ -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 diff --git a/src/Aihc/Cpp.hs b/src/Aihc/Cpp.hs new file mode 100644 --- /dev/null +++ b/src/Aihc/Cpp.hs @@ -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 "" +-- +-- 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 "" +-- +-- ((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 "" +-- +-- +-- debug mode +-- +-- +-- +-- +-- === 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 "" +-- #line 1 "./header.h" +-- -- header content +-- #line 2 "" +-- 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 "" +-- Diagnostic {diagSeverity = Error, diagMessage = "missing include: missing.h", diagFile = "", 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 "" +-- +-- Diagnostic {diagSeverity = Warning, diagMessage = "This is a warning", diagFile = "", 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 "" +-- +-- Diagnostic {diagSeverity = Error, diagMessage = "Build failed", diagFile = "", 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 '\' 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 @\@ 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 <> "\"" diff --git a/src/Aihc/Cpp/Cursor.hs b/src/Aihc/Cpp/Cursor.hs new file mode 100644 --- /dev/null +++ b/src/Aihc/Cpp/Cursor.hs @@ -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 #-} diff --git a/src/Aihc/Cpp/Evaluator.hs b/src/Aihc/Cpp/Evaluator.hs new file mode 100644 --- /dev/null +++ b/src/Aihc/Cpp/Evaluator.hs @@ -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 diff --git a/src/Aihc/Cpp/Parser.hs b/src/Aihc/Cpp/Parser.hs new file mode 100644 --- /dev/null +++ b/src/Aihc/Cpp/Parser.hs @@ -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 == '>' diff --git a/src/Aihc/Cpp/Scanner.hs b/src/Aihc/Cpp/Scanner.hs new file mode 100644 --- /dev/null +++ b/src/Aihc/Cpp/Scanner.hs @@ -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' diff --git a/src/Aihc/Cpp/Types.hs b/src/Aihc/Cpp/Types.hs new file mode 100644 --- /dev/null +++ b/src/Aihc/Cpp/Types.hs @@ -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 @\"\\"@ +-- * '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 = "", + 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 + } diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -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 \"\"\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 \"\"\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 \"\"\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 \"\"\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 \"\"", "x = \"a\\ \\b\""]), + testCase "ordinary string preserves GHC single-backslash gap" $ + assertPreprocessOutput + ghcStringGapInput + (T.unlines ["#line 1 \"\"", "x = \"a\\", " \\b\""]), + testCase "function macro argument accepts GCC double-backslash continuation" $ + assertPreprocessOutput + gccStringContinuationMacroInput + (T.unlines ["#line 1 \"\"", "", "x = \"a\\ \\b\""]), + testCase "function macro argument preserves GHC single-backslash gap" $ + assertPreprocessOutput + ghcStringGapMacroInput + (T.unlines ["#line 1 \"\"", "", "x = \"a\\", " \\b\""]), + testCase "GCC continuation tracks string gaps across concatenation" $ + assertPreprocessOutput + gccStringContinuationConcatInput + (T.unlines ["#line 1 \"\"", "x = \"a\\ \\\" <> y <> \"\\n\\ \\b\""]), + testCase "double backslash outside strings is not line-spliced" $ + assertPreprocessOutput + nonStringDoubleBackslashInput + (T.unlines ["#line 1 \"\"", "", "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 \"\"\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 \"\"\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 \"\"\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 \"\"\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 \"\"\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)" + ] diff --git a/test/Test/Progress.hs b/test/Test/Progress.hs new file mode 100644 --- /dev/null +++ b/test/Test/Progress.hs @@ -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 "" . 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