diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,7 @@ +# 0.5.0 +- Redesigned library API +The `Hpp` module exports the main pieces. `Hpp.Env`, `Hpp.Types`, and `Hpp.Config` may be used for configuring the preprocessor. + # 0.4.0 - Simplify the parsing machinery diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,3 +1,4 @@ +# The `hpp` Executable `hpp` is a Haskell pre-processor that is also a C90-compatible pre-processor (with the addition of a `--cpp` flag). It is packaged as both a library and an executable. @@ -30,3 +31,58 @@ ``` Note that you will need to ensure that the `hpp` executable is available in your build environment (e.g. you can add `hpp` as a `build-depends` in your `.cabal` file). + +# The `hpp` Library + +The `hpp` executable is a command-line interface to the `hpp` library. While the `hpp` package has been designed to have minimal dependencies beyond what the `GHC` compiler itself uses, it does include a few small, framework-free unit tests that demonstrate basic usage as a library. In the `testIf` example, we preprocess the `sourceIfDef` input with a starting definition equivalent to `#define FOO 1`. In `testArith1`, we exercise basic integer arithmetic and comparison. The `hppHelper` function shows how to run your source input through the preprocessor: `runHpp initialState (preproces mySource)`. + +```haskell +{-# LANGUAGE LambdaCase, OverloadedStrings #-} +import Control.Monad.Trans.Except +import Data.ByteString.Char8 (ByteString) +import Data.Maybe (fromMaybe) +import Data.Monoid ((<>)) +import Hpp +import System.Exit + +sourceIfdef :: [ByteString] +sourceIfdef = [ "#ifdef FOO" + , "x = 42" + , "#else" + , "x = 99" + , "#endif" ] + +sourceArith1 :: ByteString -> [ByteString] +sourceArith1 s = [ "#define x 3" + , "#if 5 + x > " <> s + , "yay" + , "#else" + , "boo" + , "#endif" ] + +hppHelper :: HppState -> [ByteString] -> [ByteString] -> IO Bool +hppHelper st src expected = runExceptT (runHpp st (preprocess src)) >>= \case + Left e -> putStrLn ("Error running hpp: " ++ show e) >> return False + Right (res, _) -> if hppOutput res == expected + then return True + else do putStr ("Expected "++show expected++", got") + print (hppOutput res) + return False + +testElse :: IO Bool +testElse = hppHelper emptyHppState sourceIfdef ["x = 99\n","\n"] + +testIf :: IO Bool +testIf = hppHelper (fromMaybe (error "Preprocessor definition did not parse") + (addDefinition "FOO" "1" emptyHppState)) + sourceIfdef + ["x = 42\n","\n"] + +testArith1 :: IO Bool +testArith1 = (&&) <$> hppHelper emptyHppState (sourceArith1 "7") ["yay\n","\n"] + <*> hppHelper emptyHppState (sourceArith1 "8") ["boo\n","\n"] + +main :: IO () +main = do results <- sequenceA [testElse, testIf, testArith1] + if and results then exitWith ExitSuccess else exitWith (ExitFailure 1) +``` diff --git a/hpp.cabal b/hpp.cabal --- a/hpp.cabal +++ b/hpp.cabal @@ -1,5 +1,5 @@ name: hpp -version: 0.4.1 +version: 0.5.0 synopsis: A Haskell pre-processor description: See the README for usage examples license: BSD3 @@ -26,11 +26,12 @@ Hpp.Expansion, Hpp.Expr, Hpp.Parser, + Hpp.RunHpp, Hpp.String, Hpp.StringSig, Hpp.Tokens, Hpp.Types - build-depends: base >=4.8 && <4.11, directory, time >=1.5, filepath, + build-depends: base >=4.8 && <4.12, directory, time >=1.5, filepath, transformers >=0.4, bytestring, bytestring-trie, ghc-prim if impl(ghc < 8) @@ -42,7 +43,13 @@ executable hpp main-is: src/Main.hs - build-depends: hpp, base >=4.8 && <4.11, directory, time >=1.5, filepath + build-depends: hpp, base >=4.8 && <4.12, directory, time >=1.5, filepath hs-source-dirs: . default-language: Haskell2010 ghc-options: -Wall + +test-suite aslib + type: exitcode-stdio-1.0 + main-is: tests/AsLib.hs + build-depends: base, hpp, transformers, bytestring + default-language: Haskell2010 diff --git a/src/Hpp.hs b/src/Hpp.hs --- a/src/Hpp.hs +++ b/src/Hpp.hs @@ -1,647 +1,99 @@ -{-# LANGUAGE BangPatterns, ConstraintKinds, LambdaCase, OverloadedStrings, - ScopedTypeVariables, TupleSections, ViewPatterns #-} +{-# LANGUAGE GeneralizedNewtypeDeriving, TupleSections #-} -- | Front-end interface to the pre-processor. module Hpp (parseDefinition, preprocess, - hppReadFile, hppIO, HppCaps, hppFileContents) where -import Control.Arrow (first) -import Control.Monad (unless) -import Control.Monad.Trans.Class (lift) -import Control.Monad.Trans.Except + T.HppState, emptyHppState, initHppState, addDefinition, + runHpp, streamHpp, HppT, HppOutput(..)) where import Control.Monad.IO.Class (MonadIO, liftIO) -import Control.Monad.Trans.State.Strict (StateT, evalStateT) -import Data.Char (isSpace) +import Control.Monad.Trans.Class (lift, MonadTrans) +import Control.Monad.Trans.Except (ExceptT, throwE) +import Control.Monad.Trans.State.Strict (StateT, runStateT) +import Data.ByteString.Char8 (ByteString) import Data.IORef import Data.Maybe (fromMaybe) -import Data.Monoid ((<>)) -import Data.String (fromString) -import Hpp.Config (Config, curFileNameF, curFileName, includePaths, - eraseCComments, spliceLongLines, inhibitLinemarkers, - replaceTrigraphs) -import Hpp.Env (deleteKey, insertPair, lookupKey) -import Hpp.Expansion (expandLine) -import Hpp.Expr (evalExpr, parseExpr) -import Hpp.Parser (Parser, ParserT, replace, await, awaitJust, droppingWhile, - precede, takingWhile, insertInputSegment, onElements, - evalParse, onInputSegment) -import Hpp.StringSig -import Hpp.Tokens (Token(..), importants, isImportant, newLine, trimUnimportant, - detokenize, notImportant, tokenize, skipLiteral) -import Hpp.Types -import System.Directory (doesFileExist) -import System.FilePath (()) -import Text.Read (readMaybe) -import Prelude hiding (String) -import qualified Prelude as P - --- * Trigraphs - --- | The first component of each pair represents the end of a known --- trigraph sequence (each trigraph begins with two consecutive --- question marks (@"??"@). The second component is the --- single-character equivalent that we substitute in for the trigraph. -trigraphs :: [(Char, Char)] -trigraphs = [ ('=', '#') - , ('/', '\\') - , ('\'', '^') - , ('(', '[') - , (')', ']') - , ('!', '|') - , ('<', '{') - , ('>', '}') - , ('-', '~') ] - -trigraphReplacement :: Stringy s => s -> s -trigraphReplacement s = aux (breakOn [("??", ())] s) - where aux Nothing = s - aux (Just (_, pre, pos)) = - case uncons pos of - Nothing -> pre <> "??" - Just (c,t) -> - case lookup c trigraphs of - Just c' -> snoc pre c' <> trigraphReplacement t - Nothing -> snoc pre '?' <> trigraphReplacement (cons '?' pos) - --- * Line Splicing - --- | If a line ends with a backslash, it is prepended to the following --- the line. -lineSplicing :: Stringy s => [s] -> [s] -lineSplicing = go id - where go acc [] = [acc mempty] - go acc (ln:lns) = case unsnoc ln of - Nothing -> acc mempty : go id lns - Just (ini, '\\') -> go (acc . (ini<>)) lns - Just _ -> acc ln : go id lns -{-# INLINE lineSplicing #-} - --- * C Comments - -breakBlockCommentStart :: Stringy s => s -> Maybe (s, s) -breakBlockCommentStart s = - case breakCharOrSub '"' "/*" s of - NoMatch -> Nothing - CharMatch pre pos -> let (lit, rest) = skipLiteral pos - in first ((pre <> lit) <>) <$> - breakBlockCommentStart rest - SubMatch pre pos -> Just (pre, pos) - -breakBlockCommentEnd :: Stringy s => s -> Maybe s -breakBlockCommentEnd s = - case breakCharOrSub '"' "*/" s of - NoMatch -> Nothing - CharMatch _ pos -> let (_, rest) = skipLiteral pos - in breakBlockCommentEnd rest - SubMatch _ pos -> Just pos - -dropOneLineBlockComments :: Stringy s => s -> s -dropOneLineBlockComments s = - case breakCharOrSub '"' "/*"s of - NoMatch -> s - CharMatch pre pos -> - let (lit,rest) = skipLiteral pos - in snoc pre '"' <> lit <> dropOneLineBlockComments rest - SubMatch pre pos -> - case breakOn [("*/", ())] pos of - Nothing -> pre <> "/*" - Just (_,_,pos') -> snoc pre ' ' <> dropOneLineBlockComments pos' - -removeMultilineComments :: Stringy s => Int -> [s] -> [s] -removeMultilineComments !lineStart = goStart lineStart - where goStart _ [] = [] - goStart !curLine (ln:lns) = - case breakBlockCommentStart ln of - Nothing -> ln : goStart (curLine+1) lns - Just (pre,_) -> goEnd (curLine+1) pre lns - goEnd _ _ [] = error "Unmatched /*" - goEnd !curLine pre (ln:lns) = - case breakBlockCommentEnd ln of - Nothing -> goEnd (curLine+1) pre lns - Just pos - | sall isSpace (pre<>pos) -> - ("#line "<> fromString (show (curLine+1))) : goStart (curLine + 1) lns - | otherwise -> (pre<>pos) - : ("#line "<> fromString (show (curLine+1))) - : goStart (curLine+1) lns - -commentRemoval :: Stringy s => [s] -> [s] -commentRemoval = removeMultilineComments 1 . map dropOneLineBlockComments - --- * TOKEN Splices - --- | Deal with the two-character '##' token pasting/splicing --- operator. We do so eliminating spaces around the @##@ --- operator. -prepTOKENSplices :: [TOKEN] -> [TOKEN] -prepTOKENSplices = map (fmap copy) . dropSpaces [] . mergeTOKENs [] - where -- Merges ## tokens, and reverses the input list - mergeTOKENs acc [] = acc - mergeTOKENs acc (Important "#" : Important "#" : ts) = - mergeTOKENs (Important "##" : acc) (dropWhile (not . isImportant) ts) - mergeTOKENs acc (t:ts) = mergeTOKENs (t : acc) ts - -- Drop trailing spaces and re-reverse the list - dropSpaces acc [] = acc - dropSpaces acc (t@(Important "##") : ts) = - dropSpaces (t : acc) (dropWhile (not . isImportant) ts) - dropSpaces acc (t:ts) = dropSpaces (t : acc) ts - --- * Function-like macros as Haskell functions - --- | @functionMacro parameters body arguments@ substitutes @arguments@ --- for @parameters@ in @body@ and performs stringification for uses of --- the @#@ operator and token concatenation for the @##@ operator. -functionMacro :: [String] -> [TOKEN] -> [([Scan],String)] -> [Scan] -functionMacro params body = paste - . subst body' - -- . M.fromList - . zip params' - where params' = map copy params - subst toks gamma = go toks - where go [] = [] - go (p@(Important "##"):t@(Important s):ts) = - case lookup s gamma of - Nothing -> Rescan p : Rescan t : go ts - Just (_,arg) -> - Rescan p : Rescan (Important arg) : go ts - go (t@(Important s):p@(Important "##"):ts) = - case lookup s gamma of - Nothing -> Rescan t : go (p:ts) - Just (_,arg) -> Rescan (Important arg) : go (p:ts) - go (t@(Important "##"):ts) = Rescan t : go ts - go (t@(Important ('#':.s)) : ts) = - case lookup s gamma of - Nothing -> Rescan t : go ts - Just (_,arg) -> - Rescan (Important (stringify arg)) : go ts - go (t@(Important s) : ts) = - case lookup s gamma of - Nothing -> Rescan t : go ts - Just (arg,_) -> arg ++ go ts - go (t:ts) = Rescan t : go ts - prepStringify [] = [] - prepStringify (Important "#" : ts) = - case dropWhile (not . isImportant) ts of - (Important t : ts') -> Important (cons '#' t) : prepStringify ts' - _ -> Important "#" : ts - prepStringify (t:ts) = t : prepStringify ts - - body' = prepStringify . prepTOKENSplices $ - dropWhile (not . isImportant) body - paste [] = [] - paste (Rescan (Important s) : Rescan (Important "##") - : Rescan (Important t) : ts) = - paste (Rescan (Important (trimSpaces s <> sdropWhile isSpace t)) : ts) - paste (t:ts) = t : paste ts - --- * Pre-Processor Capabilities - -modifyState :: (Monad m, HasHppState m) => (HppState -> HppState) -> m () -modifyState f = getState >>= setState . f - --- | Run a Stream with a configuration for a new file. -streamNewFile :: (Monad m, HasHppState m) - => FilePath -> [[TOKEN]] -> Parser m [TOKEN] () -streamNewFile fp s = - do (oldCfg,oldLine) <- do st <- getState - let cfg = hppConfig st - cfg' = cfg { curFileNameF = pure fp } - ln = hppLineNum st - setState (st {hppConfig = cfg', hppLineNum = 1}) - return (cfg, ln) - insertInputSegment - s (modifyState (setL lineNum oldLine . setL config oldCfg)) - --- * Finding @include@ files - -includeCandidates :: [FilePath] -> P.String -> Maybe [FilePath] -includeCandidates searchPath nm = - case nm of - '<':nm' -> Just $ sysSearch (init nm') - '"':nm' -> let nm'' = init nm' - in Just $ nm'' : sysSearch nm'' - _ -> Nothing - where sysSearch f = map ( f) searchPath - -searchForInclude :: [FilePath] -> P.String -> IO (Maybe FilePath) -searchForInclude paths = maybe (return Nothing) aux . includeCandidates paths - where aux [] = return Nothing - aux (f:fs) = do exists <- doesFileExist f - if exists then return (Just f) else aux fs - -searchForNextInclude :: [FilePath] -> P.String -> IO (Maybe FilePath) -searchForNextInclude paths = maybe (return Nothing) (aux False) - . includeCandidates paths - where aux _ [] = return Nothing - aux n (f:fs) = do exists <- doesFileExist f - if exists - then if n - then return (Just f) - else aux True fs - else aux n fs - --- * Running an Hpp Action - -runHpp :: forall m a src. (MonadIO m, HasHppState m) - => (FilePath -> m src) - -> (src -> m ()) - -> HppT src m a - -> m (Either (FilePath,Error) a) -runHpp source sink m = runHppT m >>= go - where go :: FreeF (HppF src) a (HppT src m a) - -> m (Either (FilePath, Error) a) - go (PureF x) = return $ Right x - go (FreeF s) = case s of - ReadFile ln file k -> - (includePaths <$> use config) - >>= liftIO . flip searchForInclude file - >>= readAux ln file k - ReadNext ln file k -> - (includePaths <$> use config) - >>= liftIO . flip searchForNextInclude file - >>= readAux ln file k - WriteOutput output k -> sink output >> runHppT k >>= go - - readAux ln file _ Nothing = - Left . (, IncludeDoesNotExist ln file) . curFileName <$> use config - readAux _ln _file k (Just file') = - source file' >>= runHppT . k >>= go -{-# SPECIALIZE runHpp :: - (FilePath -> Parser (StateT HppState (ExceptT Error IO)) [TOKEN] [String]) - -> ([String] -> Parser (StateT HppState (ExceptT Error IO)) [TOKEN] ()) - -> HppT [String] (Parser (StateT HppState (ExceptT Error IO)) [TOKEN]) a - -> Parser (StateT HppState (ExceptT Error IO)) [TOKEN] (Either (FilePath,Error) a) #-} - --- * Preprocessor - --- | Parse the definition of an object-like or function macro. -parseDefinition :: [TOKEN] -> Maybe (String, Macro) -parseDefinition toks = - case dropWhile (not . isImportant) toks of - (Important name:Important "(":rst) -> - let params = takeWhile (/= ")") $ filter (/= ",") (importants rst) - body = trimUnimportant . tail $ dropWhile (/= Important ")") toks - macro = Function (length params) (functionMacro params body) - in Just (name, macro) - (Important name:_) -> - let rhs = case dropWhile (/= Important name) toks of - [] -> [Important ""] - str@(_:t) - | all (not . isImportant) str -> [Important ""] - | otherwise -> trimUnimportant t - in Just (copy name, Object (map (fmap copy) rhs)) - _ -> Nothing - --- | Returns everything up to the next newline. The newline character --- itself is consumed. -takeLine :: (Monad m, HasError m, HasHppState m) => Parser m [TOKEN] [TOKEN] -takeLine = (onElements $ do - ln <- takingWhile (not . newLine) - eat <- awaitJust "takeLine" -- Eat the newline character - case eat of - Other "\n" -> return () - wat -> error $ "Expected newline: "++show wat++" after "++show ln - return ln) - <* (lineNum %= (+1)) - -dropLine :: (Monad m, HasError m, HasHppState m) => Parser m [TOKEN] () -dropLine = do onElements $ do - droppingWhile (not . newLine) - eat <- awaitJust "dropLine" -- Eat the newline character - case eat of - Other "\n" -> return () - wat -> error $ "Expected dropped newline: "++show wat - lineNum %= (+1) - --- * State Zooming - -expandLineP :: (Monad m, HasHppState m, HasEnv m, HasError m) - => Parser m [TOKEN] [TOKEN] -expandLineP = - do st <- getState - let ln = hppLineNum st - cfg = hppConfig st - expandLine cfg ln - -hppReadFile :: Monad m => Int -> FilePath -> HppT src m src -hppReadFile n file = HppT (pure (FreeF (ReadFile n file return))) - -hppReadNext :: Monad m => Int -> FilePath -> HppT src m src -hppReadNext n file = HppT (pure (FreeF (ReadNext n file return))) - --- * Directive Processing - --- | Handle preprocessor directives (commands prefixed with an octothorpe). -directive :: forall m. (Monad m, HppCaps m) - => HppT [String] (Parser m [TOKEN]) Bool -directive = lift (onElements (awaitJust "directive")) >>= aux - where aux :: TOKEN -> HppT [String] (Parser m [TOKEN]) Bool - aux (Important cmd) = case cmd of - "pragma" -> True <$ lift dropLine -- Ignored - "define" -> True <$ - (lift $ fmap parseDefinition takeLine >>= \case - Nothing -> use lineNum >>= - throwError . BadMacroDefinition - Just def -> env %= insertPair def) - "undef" -> do name <- lift . onElements $ do - droppingWhile (not . isImportant) - Important name <- awaitJust "undef" - return name - lift dropLine - env %= deleteKey name - return True - "include" -> True <$ includeAux hppReadFile - "include_next" -> True <$ includeAux hppReadNext - "line" -> do lift (onElements droppingSpaces) - toks <- lift (init <$> expandLineP) - case toks of - Important (toChars -> n):optFile -> - case readMaybe n of - Nothing -> use lineNum >>= - throwError . flip BadLineArgument n - Just ln' -> do - unless (null optFile) $ do - let fn = toChars . unquote . detokenize - . dropWhile (not . isImportant) - $ optFile - config %= (\cfg -> cfg { curFileNameF = pure fn }) - lineNum .= ln' - return True - _ -> use lineNum >>= - throwError - . flip BadLineArgument (toChars (detokenize toks)) - "ifdef" -> - do toks <- lift (onElements droppingSpaces >> takeLine) - ln <- use lineNum - case takeWhile isImportant toks of - [Important t] -> - lookupMacro t >>= \case - Nothing -> - lift (dropBranchLine ln >>= replace . fst) - Just _ -> - lift (onInputSegment (takeBranchFun ln)) -- (takeBranch ln >>= precede) - _ -> throwError . UnknownCommand ln $ - "ifdef "++ toChars (detokenize toks) - return True - "ifndef" -> - do toks <- lift (onElements droppingSpaces >> takeLine) - ln <- use lineNum - case takeWhile isImportant toks of - [Important t] -> - lookupMacro t >>= \case - Nothing -> lift (onInputSegment (takeBranchFun ln)) -- takeBranch ln >>= precede) - Just _ -> lift (dropBranchLine ln >>= replace . fst) - _ -> throwError . UnknownCommand ln $ - "ifndef "++ toChars (detokenize toks) - return True - "else" -> True <$ lift dropLine - "if" -> True <$ ifAux - "elif" -> True <$ ifAux - "endif" -> True <$ lift dropLine - "error" -> do toks <- lift (onElements droppingSpaces >> takeLine) - ln <- subtract 1 <$> use lineNum - curFile <- curFileName <$> use config - let tokStr = toChars (detokenize toks) - throwError $ UserError ln (tokStr++" ("++curFile++")") - "warning" -> True <$ lift dropLine -- warnings not yet supported - -- t -> do toks <- lift takeLine - -- ln <- subtract 1 <$> use lineNum - -- throwError $ UnknownCommand ln (detokenize (Important t:toks)) - _ -> return False -- Ignore unknown command - aux _ = error "Impossible unimportant directive" - includeAux :: (LineNum -> FilePath -> HppT src (Parser m [TOKEN]) [String]) - -> HppT src (Parser m [TOKEN]) () - includeAux readFun = - do fileName <- lift (toChars . detokenize . trimUnimportant . init - <$> expandLineP) - ln <- use lineNum - src <- prepareInput <*> readFun ln fileName - lineNum .= ln+1 - lift (streamNewFile (unquote fileName) src) - {- SPECIALIZE includeAux :: - (LineNum -> FilePath -> HppT [String] (Parser (StateT HppState (ExceptT Error IO)) [TOKEN]) [String]) - -> HppT [String] (Parser (StateT HppState (ExceptT Error IO)) [TOKEN]) () #-} - ifAux = - do toks <- lift (onElements droppingSpaces >> takeLine) - e <- use env - ln <- use lineNum - lineNum .= ln - 1 -- takeLine incremented the line count - ex <- lift (lift (evalParse expandLineP [squashDefines e toks])) - let res = evalExpr <$> parseExpr (map (fmap toChars) ex) - lineNum .= ln - if maybe False (/= 0) res - then lift (onInputSegment (takeBranchFun ln)) -- (takeBranch ln >>= precede) - else lift (dropBranchLine ln >>= replace . fst) - -{-# SPECIALIZE directive :: - HppT [String] (Parser (StateT HppState (ExceptT Error IO)) [TOKEN]) Bool #-} - --- | We want to expand macros in expressions that must be evaluated --- for conditionals, but we want to take special care when dealing --- with the meta @defined@ operator of the expression language that is --- a predicate on the evaluation environment. -squashDefines :: Env -> [TOKEN] -> [TOKEN] -squashDefines _ [] = [] -squashDefines env' (Important "defined" : ts) = go ts - where go (t@(Other _) : ts') = t : go ts' - go (t@(Important "(") : ts') = t : go ts' - go (Important t : ts') = - case lookupKey t env' of - Nothing -> Important "0" : squashDefines env' ts' - -- Just (_,env'') -> Important "1" : squashDefines env'' ts' - Just _ -> Important "1" : squashDefines env' ts' - go [] = [] -squashDefines env' (t : ts) = t : squashDefines env' ts - -getCmd :: [TOKEN] -> Maybe String -getCmd = aux . dropWhile notImportant - where aux (Important "#" : ts) = case dropWhile notImportant ts of - (Important cmd:_) -> Just cmd - _ -> Nothing - aux _ = Nothing - -droppingSpaces ::(Monad m) => ParserT m src TOKEN () -droppingSpaces = droppingWhile notImportant - -dropBranchFun :: [[TOKEN]] -> (Int, [[TOKEN]]) -dropBranchFun = go (1::Int) 0 - where go _ !n [] = (n,[]) - go !nesting !n (ln:lns) = - case getCmd ln of - Just cmd - | cmd == "endif" -> if nesting == 1 - then (n, ln:lns) - else go (nesting-1) (n+1) lns - | cmd `elem` ["if","ifdef","ifndef"] -> - go (nesting+1) (n+1) lns - | cmd `elem` ["else","elif"] -> if nesting == 1 - then (n, ln : lns) - else go nesting (n+1) lns - _ -> go nesting (n+1) lns - --- | Take everything up to the end of this branch, drop all remaining --- branches (if any). -takeBranchFun :: LineNum -> [[TOKEN]] -> [[TOKEN]] -takeBranchFun = go (1::Int) - where go _ _ [] = [] -- error: unterminated conditional - go 0 !n lns = yieldLineNum n : lns - go !nesting !n (ln:lns) = - case getCmd ln of - Just cmd - | cmd `elem` ["if","ifdef","ifndef"] -> - ln : go (nesting+1) (n+1) lns - | cmd == "endif" -> ln : go (nesting - 1) (n + 1) lns - | nesting == 1 && cmd `elem` ["else","elif"] -> - let (numSkipped, lns') = dropBranchFun lns - in go 1 (n+1+numSkipped) lns' - _ -> ln : go nesting (n+1) lns - - -yieldLineNum :: LineNum -> [TOKEN] -yieldLineNum !ln = [Important ("#line " <> fromString (show ln)), Other "\n"] - -dropBranchLine :: (HasError m, Monad m) - => LineNum -> Parser m [TOKEN] ([TOKEN], LineNum) -dropBranchLine !ln = do (el, numSkipped) <- dropBranch - let ln' = ln + numSkipped - return (yieldLineNum ln' ++ fromMaybe [] el, ln') - --- | Skip to the end of a conditional branch. Returns the 'Just' the --- token that ends this branch if it is an @else@ or @elif@, or --- 'Nothing' otherwise, and the number of lines skipped. -dropBranch :: (HasError m, Monad m) => Parser m [TOKEN] (Maybe [TOKEN], Int) -dropBranch = go (1::Int) 0 - where go !nesting !n = - do ln <- awaitJust "dropBranch" - case getCmd ln of - Just cmd - | cmd == "endif" -> if nesting == 1 - then return (Nothing, n+1) - else go (nesting-1) (n+1) - | cmd `elem` ["if","ifdef","ifndef"] -> - go (nesting+1) (n+1) - | cmd `elem` ["else", "elif"] -> if nesting == 1 - then return (Just ln, n+1) - else go nesting (n+1) - _ -> go nesting (n+1) - --- | Expands an input line producing a stream of output lines. -macroExpansion :: (Monad m, HppCaps m) - => HppT [String] (Parser m [TOKEN]) (Maybe [TOKEN]) -macroExpansion = do - lift await >>= \case - Nothing -> return Nothing - Just ln -> - -- when (not (all isSpace (detokenize ln))) - -- (trace ("macro expand: "++detokenize ln) (return ())) >> - case dropWhile notImportant ln of - [] -> Just ln <$ (lineNum %= (+1)) - Important "#":rst -> do lift (replace (dropWhile notImportant rst)) - processed <- directive - if processed - then macroExpansion - else Just ln <$ lift takeLine - _ -> lift (replace ln >> (Just <$> expandLineP)) <* (lineNum %= (+1)) - --- | The dynamic capabilities offered by HPP -type HppCaps t = (HasError t, HasHppState t, HasEnv t) - -parseStreamHpp :: Monad m - => HppT t (Parser m i) (Maybe t) -> HppT t (Parser m i) () -parseStreamHpp m = go - where go = m >>= \case - Nothing -> return () - Just o -> writeOutput o >> go - --- * HPP configurations - --- | Standard CPP settings for processing C files. -normalCPP :: [String] -> [[TOKEN]] -normalCPP = map ((++ [Other "\n"]) . tokenize) - . lineSplicing - -- . map dropLineComments - . removeMultilineComments 1 - . map (dropOneLineBlockComments . trigraphReplacement) -{-# INLINABLE normalCPP #-} +import qualified Hpp.Config as C +import qualified Hpp.Env as E +import qualified Hpp.RunHpp as R +import qualified Hpp.Types as T +import Hpp.Parser (evalParse, Parser) +import Hpp.StringSig (readLines) +import Hpp.Tokens (tokenize) --- | For Haskell we do not want trigraph replacement. -haskellCPP :: [String] -> [[TOKEN]] -haskellCPP = map ((++[Other "\n"]) . tokenize) - . lineSplicing - . commentRemoval -{-# INLINABLE haskellCPP #-} +-- | The type of preprocessor actions. Created with 'preprocess' and +-- executed with 'runHpp' or 'streamHpp'. +newtype HppT m a = + HppT (T.HppT [ByteString] + (Parser (StateT T.HppState (ExceptT T.Error m)) + [T.TOKEN]) + a) + deriving (Functor, Applicative, Monad) --- | If we don't have a predefined processor, we build one based on a --- 'Config' value. -genericConfig :: Config -> [String] -> [[TOKEN]] -genericConfig cfg = map ((++ [Other "\n"]) . tokenize) - . (if spliceLongLines cfg then lineSplicing else id) - . (if eraseCComments cfg then commentRemoval else id) - . (if replaceTrigraphs cfg then map trigraphReplacement else id) +instance MonadTrans HppT where + lift = HppT . lift . lift . lift . lift --- * Front End +-- | The result of running hpp +data HppOutput = HppOutput { hppFilesRead :: [FilePath] + , hppOutput :: [ByteString] } -prepareInput :: (Monad m, HppCaps m) => m ([String] -> [[TOKEN]]) -prepareInput = - do cfg <- getL config <$> getState - case () of - _ | eraseCComments cfg && spliceLongLines cfg - && not (inhibitLinemarkers cfg) -> pure normalCPP - _ | (eraseCComments cfg && spliceLongLines cfg - && (not (replaceTrigraphs cfg))) -> - pure haskellCPP - _ | otherwise -> pure (genericConfig cfg) +-- | Preprocess lines of input. +preprocess :: Monad m => [ByteString] -> HppT m () +preprocess = HppT . R.preprocess --- | Run a stream of lines through the preprocessor. -preprocess :: (Monad m, HppCaps m) - => [String] -> HppT [String] (Parser m [TOKEN]) () -preprocess src = - do cfg <- getL config <$> getState - prep <- prepareInput - let prepOutput = if inhibitLinemarkers cfg then aux else pure - lift (precede (prep src)) - parseStreamHpp (fmap (prepOutput . detokenize) <$> macroExpansion) - where aux xs | sIsPrefixOf "#line" xs = [] - | otherwise = [xs] +-- | Run a preprocessor action with some initial state. Returns the +-- result of preprocessing as well as an updated preprocessor state +-- representation. +runHpp :: MonadIO m + => T.HppState + -> HppT m a + -> ExceptT T.Error m (HppOutput, T.HppState) +runHpp st h = + do r <- liftIO (newIORef id) + let snk xs = modifyIORef r (. (xs++)) + let fin (x, st') = do outLines <- ($ []) <$> readIORef r + return (HppOutput x outLines, st') + streamHpp st (liftIO . snk) h >>= liftIO . fin --- Note: `preprocess` is the workhorse of the library. We run the --- value it returns in `hppIO'` by interleaving interpretation of --- `HppT` with binds of types providing the `HppCaps` --- capabilities. When making things concrete, we specialize to --- `ExceptT`, `StateT`, and `Parser` (note that `Parser` is actually --- just another `StateT`). +-- | @streamHpp state sink action@ runs a preprocessor @action@ with +-- some initial @state@. Output is streamed to the caller-provided +-- output @sink@ as it is generated. The list of files read during +-- preprocessing is returned along with an updated preprocessor state +-- representation. +streamHpp :: MonadIO m + => T.HppState + -> ([ByteString] -> m ()) + -> HppT m a + -> ExceptT T.Error m ([FilePath], T.HppState) +streamHpp st snk (HppT h) = + do (a, st') <- runStateT + (evalParse + (R.runHpp (liftIO . readLines) + (lift . lift . lift . snk) h) + []) + st + either (throwE . snd) (return . (,st') . R.hppFilesRead) a --- | A concreate choice of types to satisfy `HppCaps` as required by --- `preprocess`. -dischargeHppCaps :: Monad m - => Config -> Env - -> Parser (StateT HppState (ExceptT Error m)) - i - (Either (a, Error) b) - -> m (Maybe Error) -dischargeHppCaps cfg env' m = - runExceptT - (evalStateT - (evalParse (m >>= either (throwError . snd) return) []) - initialState) - >>= return . either Just (const Nothing) - where initialState = setL env env' $ emptyHppState cfg +-- | An 'T.HppState' containing no macro definitions, and default +-- values for the starting configuration: the name of the current file +-- is @\"NoFile\"@, there are no paths to be searched for included +-- files, etc. See 'C.Config' for more information on available +-- configuration. +emptyHppState :: T.HppState +emptyHppState = T.emptyHppState + $ fromMaybe (error "emptyHppState assumption wrong") + (C.realizeConfig cfg) + where cfg = C.defaultConfigF { C.curFileNameF = Just "NoFile" } --- | General hpp runner against input source file lines; can return an --- 'Error' value if something goes wrong. -hppIO' :: Config -> Env -> ([String] -> IO ()) -> [String] -> IO (Maybe Error) -hppIO' cfg env' snk src = - dischargeHppCaps cfg env' $ - runHpp (liftIO . readLines) (liftIO . snk) (preprocess src) +-- | Create a 'T.HppState' with the given 'C.Config' and 'T.Env'. +initHppState :: C.Config -> T.Env -> T.HppState +initHppState c e = T.HppState c 1 e --- | General hpp runner against input source file lines. Any errors --- encountered are thrown with 'error'. -hppIO :: Config -> Env -> ([String] -> IO ()) -> [String] -> IO () -hppIO cfg env' snk = fmap (maybe () (error . show)) . hppIO' cfg env' snk +-- | @addDefinition name expression@ adds a binding of @name@ to +-- @expression@ in the preprocessor’s internal state. +addDefinition :: ByteString -> ByteString -> T.HppState -> Maybe T.HppState +addDefinition name val s = flip (T.over T.env) s . E.insertPair + <$> parseDefinition name val --- | hpp runner that returns output lines. -hppFileContents :: Config -> Env -> FilePath -> [String] -> IO (Either Error [String]) -hppFileContents cfg env' fileName src = do - r <- newIORef id - let snk xs = modifyIORef r (. (xs++)) - hppIO' (cfg {curFileNameF = pure fileName}) env' snk src >>= \case - Nothing -> Right . ($ []) <$> readIORef r - Just e -> return (Left e) +-- | Lower level parsing of macro definitions. Will typically be used +-- with 'E.insertPair' for manual construction of a 'T.Env' binding +-- environment. +parseDefinition :: ByteString -> ByteString -> Maybe (ByteString, T.Macro) +parseDefinition name val = R.parseDefinition (tokenize name ++ tokenize val) diff --git a/src/Hpp/CmdLine.hs b/src/Hpp/CmdLine.hs --- a/src/Hpp/CmdLine.hs +++ b/src/Hpp/CmdLine.hs @@ -3,12 +3,12 @@ -- line invocation. module Hpp.CmdLine (runWithArgs) where import Control.Monad (unless) +import Control.Monad.Trans.Except (runExceptT) import Data.String (fromString) import Hpp import Hpp.Config import Hpp.Env (deleteKey, emptyEnv, insertPair) import Hpp.StringSig (readLines, putStringy) -import Hpp.Tokens import Hpp.Types (Env, Error(..)) import System.Directory (doesFileExist, makeAbsolute) import System.IO (openFile, IOMode(..), hClose, stdout) @@ -40,11 +40,11 @@ Just cfg' -> return (Right (env, acc [], cfg', out)) Nothing -> return (Left NoInputFile) go env acc cfg out ("-D":name:"=":body:rst) = - case parseDefinition (Important (fromString name) : Other " " : tokenize (fromString body)) of + case parseDefinition (fromString name) (fromString body) of Nothing -> return . Left $ BadMacroDefinition 0 Just def -> go (insertPair def env) acc cfg out rst go env acc cfg out ("-D":name:rst) = - case parseDefinition ([Important (fromString name), Other " ", Important "1"]) of + case parseDefinition (fromString name) "1" of Nothing -> return . Left $ BadMacroDefinition 0 Just def -> go (insertPair def env) acc cfg out rst go env acc cfg out ("-U":name:rst) = @@ -105,11 +105,18 @@ Just f -> do h <- makeAbsolute f >>= flip openFile WriteMode - return (\os -> mapM_ (putStringy h) os - ,hClose h) - _ <- (readLines fileName) - >>= hppIO cfg' env snk . (map fromString lns ++) - -- lns' <- (lines <$> readFile fileName) - -- >>= hppFileContents cfg env fileName . (lns ++) - -- snk lns' + return ( \os -> mapM_ (putStringy h) os + , hClose h ) + let errorExcept = fmap (either (error . show) id) . runExceptT + _ <- readLines fileName + >>= errorExcept + . streamHpp (initHppState cfg' env) snk + . preprocess + . (map fromString lns ++) + -- (lns', _) <- readLines fileName + -- >>= errorExcept + -- . runHpp (initHppState cfg' env) + -- . preprocess + -- . (map fromString lns ++) + -- snk (hppOutput lns') closeSnk diff --git a/src/Hpp/Config.hs b/src/Hpp/Config.hs --- a/src/Hpp/Config.hs +++ b/src/Hpp/Config.hs @@ -18,13 +18,32 @@ -- Identity@. Specifically, the source file name of the file being -- processed /must/ be set. data ConfigF f = Config { curFileNameF :: f FilePath + -- ^ Name of the file being + -- preprocessed. Hpp will update this as new + -- files are included. The user must set it + -- manually for the starting input file. , includePathsF :: f [FilePath] + -- ^ Paths to be searched for included files. , spliceLongLinesF :: f Bool + -- ^ A backslash as the last character of a + -- line causes the next line to be appended to + -- the current one eliding the newline + -- character present in the source input. , eraseCCommentsF :: f Bool + -- ^ Erase line comments (starting with @//@) + -- and block comments (delimited by @/*@ and + -- @*/@). , inhibitLinemarkersF :: f Bool + -- ^ Do not emit @#line@ directives. , replaceTrigraphsF :: f Bool + -- ^ Replace trigraph sequences (each of which + -- starts with two consecutive question marks + -- (@\"??\"@) with the characters they encode. , prepDateF :: f DateString - , prepTimeF :: f TimeString } + -- ^ Format string for @\_\_DATE\_\_@. + , prepTimeF :: f TimeString + -- ^ Format string for @\_\_TIME\_\_@. + } -- | A fully-populated configuration for the pre-processor. type Config = ConfigF Identity @@ -75,7 +94,9 @@ prepTime :: Config -> TimeString prepTime = runIdentity . prepTimeF --- | A default configuration with no current file name set. +-- | A default configuration with no current file name set. Note that +-- long line splicing is enabled, C++-style comments are erased, #line +-- markers are inhibited, and trigraph replacement is disabled. defaultConfigF :: ConfigF Maybe defaultConfigF = Config Nothing (Just []) (Just True) (Just True) (Just True) (Just False) diff --git a/src/Hpp/RunHpp.hs b/src/Hpp/RunHpp.hs new file mode 100644 --- /dev/null +++ b/src/Hpp/RunHpp.hs @@ -0,0 +1,659 @@ +{-# LANGUAGE BangPatterns, ConstraintKinds, LambdaCase, OverloadedStrings, + ScopedTypeVariables, TupleSections, ViewPatterns #-} +-- | Mid-level interface to the pre-processor. +module Hpp.RunHpp (parseDefinition, preprocess, runHpp, + hppIOSink, HppCaps, hppIO, HppResult(..)) where +import Control.Arrow (first) +import Control.Exception (throwIO) +import Control.Monad (unless, (>=>)) +import Control.Monad.Trans.Class (lift) +import Control.Monad.Trans.Except +import Control.Monad.IO.Class (MonadIO, liftIO) +import Control.Monad.Trans.State.Strict (StateT, evalStateT) +import Data.Char (isSpace) +import Data.IORef +import Data.Maybe (fromMaybe) +import Data.Monoid ((<>)) +import Data.String (fromString) +import Hpp.Config (Config, curFileNameF, curFileName, includePaths, + eraseCComments, spliceLongLines, inhibitLinemarkers, + replaceTrigraphs) +import Hpp.Env (deleteKey, insertPair, lookupKey) +import Hpp.Expansion (expandLine) +import Hpp.Expr (evalExpr, parseExpr) +import Hpp.Parser (Parser, ParserT, replace, await, awaitJust, droppingWhile, + precede, takingWhile, insertInputSegment, onElements, + evalParse, onInputSegment) +import Hpp.StringSig +import Hpp.Tokens (Token(..), importants, isImportant, newLine, trimUnimportant, + detokenize, notImportant, tokenize, skipLiteral) +import Hpp.Types +import System.Directory (doesFileExist) +import System.FilePath (()) +import Text.Read (readMaybe) +import Prelude hiding (String) +import qualified Prelude as P + +-- * Trigraphs + +-- | The first component of each pair represents the end of a known +-- trigraph sequence (each trigraph begins with two consecutive +-- question marks (@\"??\"@). The second component is the +-- single-character equivalent that we substitute in for the trigraph. +trigraphs :: [(Char, Char)] +trigraphs = [ ('=', '#') + , ('/', '\\') + , ('\'', '^') + , ('(', '[') + , (')', ']') + , ('!', '|') + , ('<', '{') + , ('>', '}') + , ('-', '~') ] + +trigraphReplacement :: Stringy s => s -> s +trigraphReplacement s = aux (breakOn [("??", ())] s) + where aux Nothing = s + aux (Just (_, pre, pos)) = + case uncons pos of + Nothing -> pre <> "??" + Just (c,t) -> + case lookup c trigraphs of + Just c' -> snoc pre c' <> trigraphReplacement t + Nothing -> snoc pre '?' <> trigraphReplacement (cons '?' pos) + +-- * Line Splicing + +-- | If a line ends with a backslash, it is prepended to the following +-- the line. +lineSplicing :: Stringy s => [s] -> [s] +lineSplicing = go id + where go acc [] = [acc mempty] + go acc (ln:lns) = case unsnoc ln of + Nothing -> acc mempty : go id lns + Just (ini, '\\') -> go (acc . (ini<>)) lns + Just _ -> acc ln : go id lns +{-# INLINE lineSplicing #-} + +-- * C Comments + +breakBlockCommentStart :: Stringy s => s -> Maybe (s, s) +breakBlockCommentStart s = + case breakCharOrSub '"' "/*" s of + NoMatch -> Nothing + CharMatch pre pos -> let (lit, rest) = skipLiteral pos + in first ((pre <> lit) <>) <$> + breakBlockCommentStart rest + SubMatch pre pos -> Just (pre, pos) + +breakBlockCommentEnd :: Stringy s => s -> Maybe s +breakBlockCommentEnd s = + case breakCharOrSub '"' "*/" s of + NoMatch -> Nothing + CharMatch _ pos -> let (_, rest) = skipLiteral pos + in breakBlockCommentEnd rest + SubMatch _ pos -> Just pos + +dropOneLineBlockComments :: Stringy s => s -> s +dropOneLineBlockComments s = + case breakCharOrSub '"' "/*"s of + NoMatch -> s + CharMatch pre pos -> + let (lit,rest) = skipLiteral pos + in snoc pre '"' <> lit <> dropOneLineBlockComments rest + SubMatch pre pos -> + case breakOn [("*/", ())] pos of + Nothing -> pre <> "/*" + Just (_,_,pos') -> snoc pre ' ' <> dropOneLineBlockComments pos' + +removeMultilineComments :: Stringy s => Int -> [s] -> [s] +removeMultilineComments !lineStart = goStart lineStart + where goStart _ [] = [] + goStart !curLine (ln:lns) = + case breakBlockCommentStart ln of + Nothing -> ln : goStart (curLine+1) lns + Just (pre,_) -> goEnd (curLine+1) pre lns + goEnd _ _ [] = error "Unmatched /*" + goEnd !curLine pre (ln:lns) = + case breakBlockCommentEnd ln of + Nothing -> goEnd (curLine+1) pre lns + Just pos + | sall isSpace (pre<>pos) -> + ("#line "<> fromString (show (curLine+1))) : goStart (curLine + 1) lns + | otherwise -> (pre<>pos) + : ("#line "<> fromString (show (curLine+1))) + : goStart (curLine+1) lns + +commentRemoval :: Stringy s => [s] -> [s] +commentRemoval = removeMultilineComments 1 . map dropOneLineBlockComments + +-- * TOKEN Splices + +-- | Deal with the two-character '##' token pasting/splicing +-- operator. We do so eliminating spaces around the @##@ +-- operator. +prepTOKENSplices :: [TOKEN] -> [TOKEN] +prepTOKENSplices = map (fmap copy) . dropSpaces [] . mergeTOKENs [] + where -- Merges ## tokens, and reverses the input list + mergeTOKENs acc [] = acc + mergeTOKENs acc (Important "#" : Important "#" : ts) = + mergeTOKENs (Important "##" : acc) (dropWhile (not . isImportant) ts) + mergeTOKENs acc (t:ts) = mergeTOKENs (t : acc) ts + -- Drop trailing spaces and re-reverse the list + dropSpaces acc [] = acc + dropSpaces acc (t@(Important "##") : ts) = + dropSpaces (t : acc) (dropWhile (not . isImportant) ts) + dropSpaces acc (t:ts) = dropSpaces (t : acc) ts + +-- * Function-like macros as Haskell functions + +-- | @functionMacro parameters body arguments@ substitutes @arguments@ +-- for @parameters@ in @body@ and performs stringification for uses of +-- the @#@ operator and token concatenation for the @##@ operator. +functionMacro :: [String] -> [TOKEN] -> [([Scan],String)] -> [Scan] +functionMacro params body = paste + . subst body' + -- . M.fromList + . zip params' + where params' = map copy params + subst toks gamma = go toks + where go [] = [] + go (p@(Important "##"):t@(Important s):ts) = + case lookup s gamma of + Nothing -> Rescan p : Rescan t : go ts + Just (_,arg) -> + Rescan p : Rescan (Important arg) : go ts + go (t@(Important s):p@(Important "##"):ts) = + case lookup s gamma of + Nothing -> Rescan t : go (p:ts) + Just (_,arg) -> Rescan (Important arg) : go (p:ts) + go (t@(Important "##"):ts) = Rescan t : go ts + go (t@(Important ('#':.s)) : ts) = + case lookup s gamma of + Nothing -> Rescan t : go ts + Just (_,arg) -> + Rescan (Important (stringify arg)) : go ts + go (t@(Important s) : ts) = + case lookup s gamma of + Nothing -> Rescan t : go ts + Just (arg,_) -> arg ++ go ts + go (t:ts) = Rescan t : go ts + prepStringify [] = [] + prepStringify (Important "#" : ts) = + case dropWhile (not . isImportant) ts of + (Important t : ts') -> Important (cons '#' t) : prepStringify ts' + _ -> Important "#" : ts + prepStringify (t:ts) = t : prepStringify ts + + body' = prepStringify . prepTOKENSplices $ + dropWhile (not . isImportant) body + paste [] = [] + paste (Rescan (Important s) : Rescan (Important "##") + : Rescan (Important t) : ts) = + paste (Rescan (Important (trimSpaces s <> sdropWhile isSpace t)) : ts) + paste (t:ts) = t : paste ts + +-- * Pre-Processor Capabilities + +modifyState :: (Monad m, HasHppState m) => (HppState -> HppState) -> m () +modifyState f = getState >>= setState . f + +-- | Run a Stream with a configuration for a new file. +streamNewFile :: (Monad m, HasHppState m) + => FilePath -> [[TOKEN]] -> Parser m [TOKEN] () +streamNewFile fp s = + do (oldCfg,oldLine) <- do st <- getState + let cfg = hppConfig st + cfg' = cfg { curFileNameF = pure fp } + ln = hppLineNum st + setState (st {hppConfig = cfg', hppLineNum = 1}) + return (cfg, ln) + insertInputSegment + s (modifyState (setL lineNum oldLine . setL config oldCfg)) + +-- * Finding @include@ files + +includeCandidates :: [FilePath] -> P.String -> Maybe [FilePath] +includeCandidates searchPath nm = + case nm of + '<':nm' -> Just $ sysSearch (init nm') + '"':nm' -> let nm'' = init nm' + in Just $ nm'' : sysSearch nm'' + _ -> Nothing + where sysSearch f = map ( f) searchPath + +searchForInclude :: [FilePath] -> P.String -> IO (Maybe FilePath) +searchForInclude paths = maybe (return Nothing) aux . includeCandidates paths + where aux [] = return Nothing + aux (f:fs) = do exists <- doesFileExist f + if exists then return (Just f) else aux fs + +searchForNextInclude :: [FilePath] -> P.String -> IO (Maybe FilePath) +searchForNextInclude paths = maybe (return Nothing) (aux False) + . includeCandidates paths + where aux _ [] = return Nothing + aux n (f:fs) = do exists <- doesFileExist f + if exists + then if n + then return (Just f) + else aux True fs + else aux n fs + +-- * Running an Hpp Action + +data HppResult a = HppResult { hppFilesRead :: [FilePath] + , hppResult :: a } + +runHpp :: forall m a src. (MonadIO m, HasHppState m) + => (FilePath -> m src) + -> (src -> m ()) + -> HppT src m a + -> m (Either (FilePath,Error) (HppResult a)) +runHpp source sink m = runHppT m >>= go [] + where go :: [FilePath] + -> FreeF (HppF src) a (HppT src m a) + -> m (Either (FilePath, Error) (HppResult a)) + go files (PureF x) = return $ Right (HppResult files x) + go files (FreeF s) = case s of + ReadFile ln file k -> + (includePaths <$> use config) + >>= liftIO . flip searchForInclude file + >>= readAux (file:files) ln file k + ReadNext ln file k -> + (includePaths <$> use config) + >>= liftIO . flip searchForNextInclude file + >>= readAux (file:files) ln file k + WriteOutput output k -> sink output >> runHppT k >>= go files + + readAux _files ln file _ Nothing = + Left . (, IncludeDoesNotExist ln file) . curFileName <$> use config + readAux files _ln _file k (Just file') = + source file' >>= runHppT . k >>= go files +{-# SPECIALIZE runHpp :: + (FilePath -> Parser (StateT HppState (ExceptT Error IO)) [TOKEN] [String]) + -> ([String] -> Parser (StateT HppState (ExceptT Error IO)) [TOKEN] ()) + -> HppT [String] (Parser (StateT HppState (ExceptT Error IO)) [TOKEN]) a + -> Parser (StateT HppState (ExceptT Error IO)) [TOKEN] (Either (FilePath,Error) (HppResult a)) #-} + +-- * Preprocessor + +-- | Parse the definition of an object-like or function macro. +parseDefinition :: [TOKEN] -> Maybe (String, Macro) +parseDefinition toks = + case dropWhile (not . isImportant) toks of + (Important name:Important "(":rst) -> + let params = takeWhile (/= ")") $ filter (/= ",") (importants rst) + body = trimUnimportant . tail $ dropWhile (/= Important ")") toks + macro = Function (length params) (functionMacro params body) + in Just (name, macro) + (Important name:_) -> + let rhs = case dropWhile (/= Important name) toks of + [] -> [Important ""] + str@(_:t) + | all (not . isImportant) str -> [Important ""] + | otherwise -> trimUnimportant t + in Just (copy name, Object (map (fmap copy) rhs)) + _ -> Nothing + +-- | Returns everything up to the next newline. The newline character +-- itself is consumed. +takeLine :: (Monad m, HasError m, HasHppState m) => Parser m [TOKEN] [TOKEN] +takeLine = (onElements $ do + ln <- takingWhile (not . newLine) + eat <- awaitJust "takeLine" -- Eat the newline character + case eat of + Other "\n" -> return () + wat -> error $ "Expected newline: "++show wat++" after "++show ln + return ln) + <* (lineNum %= (+1)) + +dropLine :: (Monad m, HasError m, HasHppState m) => Parser m [TOKEN] () +dropLine = do onElements $ do + droppingWhile (not . newLine) + eat <- awaitJust "dropLine" -- Eat the newline character + case eat of + Other "\n" -> return () + wat -> error $ "Expected dropped newline: "++show wat + lineNum %= (+1) + +-- * State Zooming + +expandLineP :: (Monad m, HasHppState m, HasEnv m, HasError m) + => Parser m [TOKEN] [TOKEN] +expandLineP = + do st <- getState + let ln = hppLineNum st + cfg = hppConfig st + expandLine cfg ln + +-- | @hppReadFile lineNumber fileName@ introduces an @#include +-- @ as if it occurred at the given line number. +hppReadFile :: Monad m => Int -> FilePath -> HppT src m src +hppReadFile n file = HppT (pure (FreeF (ReadFile n file return))) + +-- | @hppReadNext lineNumber fileName@ introduces an @#include_next +-- @ as if it occurred at the given line number. +hppReadNext :: Monad m => Int -> FilePath -> HppT src m src +hppReadNext n file = HppT (pure (FreeF (ReadNext n file return))) + +-- * Directive Processing + +-- | Handle preprocessor directives (commands prefixed with an octothorpe). +directive :: forall m. (Monad m, HppCaps m) + => HppT [String] (Parser m [TOKEN]) Bool +directive = lift (onElements (awaitJust "directive")) >>= aux + where aux :: TOKEN -> HppT [String] (Parser m [TOKEN]) Bool + aux (Important cmd) = case cmd of + "pragma" -> True <$ lift dropLine -- Ignored + "define" -> True <$ + (lift $ fmap parseDefinition takeLine >>= \case + Nothing -> use lineNum >>= + throwError . BadMacroDefinition + Just def -> env %= insertPair def) + "undef" -> do name <- lift . onElements $ do + droppingWhile (not . isImportant) + Important name <- awaitJust "undef" + return name + lift dropLine + env %= deleteKey name + return True + "include" -> True <$ includeAux hppReadFile + "include_next" -> True <$ includeAux hppReadNext + "line" -> do lift (onElements droppingSpaces) + toks <- lift (init <$> expandLineP) + case toks of + Important (toChars -> n):optFile -> + case readMaybe n of + Nothing -> use lineNum >>= + throwError . flip BadLineArgument n + Just ln' -> do + unless (null optFile) $ do + let fn = toChars . unquote . detokenize + . dropWhile (not . isImportant) + $ optFile + config %= (\cfg -> cfg { curFileNameF = pure fn }) + lineNum .= ln' + return True + _ -> use lineNum >>= + throwError + . flip BadLineArgument (toChars (detokenize toks)) + "ifdef" -> + do toks <- lift (onElements droppingSpaces >> takeLine) + ln <- use lineNum + case takeWhile isImportant toks of + [Important t] -> + lookupMacro t >>= \case + Nothing -> + lift (dropBranchLine ln >>= replace . fst) + Just _ -> + lift (onInputSegment (takeBranchFun ln)) -- (takeBranch ln >>= precede) + _ -> throwError . UnknownCommand ln $ + "ifdef "++ toChars (detokenize toks) + return True + "ifndef" -> + do toks <- lift (onElements droppingSpaces >> takeLine) + ln <- use lineNum + case takeWhile isImportant toks of + [Important t] -> + lookupMacro t >>= \case + Nothing -> lift (onInputSegment (takeBranchFun ln)) -- takeBranch ln >>= precede) + Just _ -> lift (dropBranchLine ln >>= replace . fst) + _ -> throwError . UnknownCommand ln $ + "ifndef "++ toChars (detokenize toks) + return True + "else" -> True <$ lift dropLine + "if" -> True <$ ifAux + "elif" -> True <$ ifAux + "endif" -> True <$ lift dropLine + "error" -> do toks <- lift (onElements droppingSpaces >> takeLine) + ln <- subtract 1 <$> use lineNum + curFile <- curFileName <$> use config + let tokStr = toChars (detokenize toks) + throwError $ UserError ln (tokStr++" ("++curFile++")") + "warning" -> True <$ lift dropLine -- warnings not yet supported + -- t -> do toks <- lift takeLine + -- ln <- subtract 1 <$> use lineNum + -- throwError $ UnknownCommand ln (detokenize (Important t:toks)) + _ -> return False -- Ignore unknown command + aux _ = error "Impossible unimportant directive" + includeAux :: (LineNum -> FilePath -> HppT src (Parser m [TOKEN]) [String]) + -> HppT src (Parser m [TOKEN]) () + includeAux readFun = + do fileName <- lift (toChars . detokenize . trimUnimportant . init + <$> expandLineP) + ln <- use lineNum + src <- prepareInput <*> readFun ln fileName + lineNum .= ln+1 + lift (streamNewFile (unquote fileName) src) + {- SPECIALIZE includeAux :: + (LineNum -> FilePath -> HppT [String] (Parser (StateT HppState (ExceptT Error IO)) [TOKEN]) [String]) + -> HppT [String] (Parser (StateT HppState (ExceptT Error IO)) [TOKEN]) () #-} + ifAux = + do toks <- lift (onElements droppingSpaces >> takeLine) + e <- use env + ln <- use lineNum + lineNum .= ln - 1 -- takeLine incremented the line count + ex <- lift (lift (evalParse expandLineP [squashDefines e toks])) + let res = evalExpr <$> parseExpr (map (fmap toChars) ex) + lineNum .= ln + if maybe False (/= 0) res + then lift (onInputSegment (takeBranchFun ln)) -- (takeBranch ln >>= precede) + else lift (dropBranchLine ln >>= replace . fst) + +{-# SPECIALIZE directive :: + HppT [String] (Parser (StateT HppState (ExceptT Error IO)) [TOKEN]) Bool #-} + +-- | We want to expand macros in expressions that must be evaluated +-- for conditionals, but we want to take special care when dealing +-- with the meta @defined@ operator of the expression language that is +-- a predicate on the evaluation environment. +squashDefines :: Env -> [TOKEN] -> [TOKEN] +squashDefines _ [] = [] +squashDefines env' (Important "defined" : ts) = go ts + where go (t@(Other _) : ts') = t : go ts' + go (t@(Important "(") : ts') = t : go ts' + go (Important t : ts') = + case lookupKey t env' of + Nothing -> Important "0" : squashDefines env' ts' + -- Just (_,env'') -> Important "1" : squashDefines env'' ts' + Just _ -> Important "1" : squashDefines env' ts' + go [] = [] +squashDefines env' (t : ts) = t : squashDefines env' ts + +getCmd :: [TOKEN] -> Maybe String +getCmd = aux . dropWhile notImportant + where aux (Important "#" : ts) = case dropWhile notImportant ts of + (Important cmd:_) -> Just cmd + _ -> Nothing + aux _ = Nothing + +droppingSpaces ::(Monad m) => ParserT m src TOKEN () +droppingSpaces = droppingWhile notImportant + +dropBranchFun :: [[TOKEN]] -> (Int, [[TOKEN]]) +dropBranchFun = go (1::Int) 0 + where go _ !n [] = (n,[]) + go !nesting !n (ln:lns) = + case getCmd ln of + Just cmd + | cmd == "endif" -> if nesting == 1 + then (n, ln:lns) + else go (nesting-1) (n+1) lns + | cmd `elem` ["if","ifdef","ifndef"] -> + go (nesting+1) (n+1) lns + | cmd `elem` ["else","elif"] -> if nesting == 1 + then (n, ln : lns) + else go nesting (n+1) lns + _ -> go nesting (n+1) lns + +-- | Take everything up to the end of this branch, drop all remaining +-- branches (if any). +takeBranchFun :: LineNum -> [[TOKEN]] -> [[TOKEN]] +takeBranchFun = go (1::Int) + where go _ _ [] = [] -- error: unterminated conditional + go 0 !n lns = yieldLineNum n : lns + go !nesting !n (ln:lns) = + case getCmd ln of + Just cmd + | cmd `elem` ["if","ifdef","ifndef"] -> + ln : go (nesting+1) (n+1) lns + | cmd == "endif" -> ln : go (nesting - 1) (n + 1) lns + | nesting == 1 && cmd `elem` ["else","elif"] -> + let (numSkipped, lns') = dropBranchFun lns + in go 1 (n+1+numSkipped) lns' + _ -> ln : go nesting (n+1) lns + + +yieldLineNum :: LineNum -> [TOKEN] +yieldLineNum !ln = [Important ("#line " <> fromString (show ln)), Other "\n"] + +dropBranchLine :: (HasError m, Monad m) + => LineNum -> Parser m [TOKEN] ([TOKEN], LineNum) +dropBranchLine !ln = do (el, numSkipped) <- dropBranch + let ln' = ln + numSkipped + return (yieldLineNum ln' ++ fromMaybe [] el, ln') + +-- | Skip to the end of a conditional branch. Returns the 'Just' the +-- token that ends this branch if it is an @else@ or @elif@, or +-- 'Nothing' otherwise, and the number of lines skipped. +dropBranch :: (HasError m, Monad m) => Parser m [TOKEN] (Maybe [TOKEN], Int) +dropBranch = go (1::Int) 0 + where go !nesting !n = + do ln <- awaitJust "dropBranch" + case getCmd ln of + Just cmd + | cmd == "endif" -> if nesting == 1 + then return (Nothing, n+1) + else go (nesting-1) (n+1) + | cmd `elem` ["if","ifdef","ifndef"] -> + go (nesting+1) (n+1) + | cmd `elem` ["else", "elif"] -> if nesting == 1 + then return (Just ln, n+1) + else go nesting (n+1) + _ -> go nesting (n+1) + +-- | Expands an input line producing a stream of output lines. +macroExpansion :: (Monad m, HppCaps m) + => HppT [String] (Parser m [TOKEN]) (Maybe [TOKEN]) +macroExpansion = do + lift await >>= \case + Nothing -> return Nothing + Just ln -> + -- when (not (all isSpace (detokenize ln))) + -- (trace ("macro expand: "++detokenize ln) (return ())) >> + case dropWhile notImportant ln of + [] -> Just ln <$ (lineNum %= (+1)) + Important "#":rst -> do lift (replace (dropWhile notImportant rst)) + processed <- directive + if processed + then macroExpansion + else Just ln <$ lift takeLine + _ -> lift (replace ln >> (Just <$> expandLineP)) <* (lineNum %= (+1)) + +-- | The dynamic capabilities offered by HPP +type HppCaps t = (HasError t, HasHppState t, HasEnv t) + +parseStreamHpp :: Monad m + => HppT t (Parser m i) (Maybe t) -> HppT t (Parser m i) () +parseStreamHpp m = go + where go = m >>= \case + Nothing -> return () + Just o -> writeOutput o >> go + +-- * HPP configurations + +-- | Standard CPP settings for processing C files. +normalCPP :: [String] -> [[TOKEN]] +normalCPP = map ((++ [Other "\n"]) . tokenize) + . lineSplicing + -- . map dropLineComments + . removeMultilineComments 1 + . map (dropOneLineBlockComments . trigraphReplacement) +{-# INLINABLE normalCPP #-} + +-- | For Haskell we do not want trigraph replacement. +haskellCPP :: [String] -> [[TOKEN]] +haskellCPP = map ((++[Other "\n"]) . tokenize) + . lineSplicing + . commentRemoval +{-# INLINABLE haskellCPP #-} + +-- | If we don't have a predefined processor, we build one based on a +-- 'Config' value. +genericConfig :: Config -> [String] -> [[TOKEN]] +genericConfig cfg = map ((++ [Other "\n"]) . tokenize) + . (if spliceLongLines cfg then lineSplicing else id) + . (if eraseCComments cfg then commentRemoval else id) + . (if replaceTrigraphs cfg then map trigraphReplacement else id) + +-- * Front End + +prepareInput :: (Monad m, HppCaps m) => m ([String] -> [[TOKEN]]) +prepareInput = + do cfg <- getL config <$> getState + case () of + _ | eraseCComments cfg && spliceLongLines cfg + && not (inhibitLinemarkers cfg) -> pure normalCPP + _ | (eraseCComments cfg && spliceLongLines cfg + && (not (replaceTrigraphs cfg))) -> + pure haskellCPP + _ | otherwise -> pure (genericConfig cfg) + +-- | Run a stream of lines through the preprocessor. +preprocess :: (Monad m, HppCaps m) + => [String] -> HppT [String] (Parser m [TOKEN]) () +preprocess src = + do cfg <- getL config <$> getState + prep <- prepareInput + let prepOutput = if inhibitLinemarkers cfg then aux else pure + lift (precede (prep src)) + parseStreamHpp (fmap (prepOutput . detokenize) <$> macroExpansion) + where aux xs | sIsPrefixOf "#line" xs = [] + | otherwise = [xs] + +-- Note: `preprocess` is the workhorse of the library. We run the +-- value it returns in `hppIO'` by interleaving interpretation of +-- `HppT` with binds of types providing the `HppCaps` +-- capabilities. When making things concrete, we specialize to +-- `ExceptT`, `StateT`, and `Parser` (note that `Parser` is actually +-- just another `StateT`). + +-- | A concreate choice of types to satisfy `HppCaps` as required by +-- `preprocess`. +dischargeHppCaps :: Monad m + => Config -> Env + -> Parser (StateT HppState (ExceptT Error m)) + i + (Either (a, Error) b) + -> m (Either Error b) +dischargeHppCaps cfg env' m = + runExceptT + (evalStateT + (evalParse (m >>= either (throwError . snd) return) []) + initialState) + where initialState = setL env env' $ emptyHppState cfg + +-- | General hpp runner against input source file lines; can return an +-- 'Error' value if something goes wrong. +hppIOSink' :: Config -> Env -> ([String] -> IO ()) -> [String] + -> IO (Either Error [FilePath]) +hppIOSink' cfg env' snk src = + fmap (fmap hppFilesRead) + . dischargeHppCaps cfg env' $ + runHpp (liftIO . readLines) (liftIO . snk) (preprocess src) + +-- | General hpp runner against input source file lines. Output lines +-- are fed to the caller-supplied sink function. Any errors +-- encountered are thrown with 'error'. +hppIOSink :: Config -> Env -> ([String] -> IO ()) -> [String] -> IO [FilePath] +hppIOSink cfg env' snk = hppIOSink' cfg env' snk >=> either throwIO return + +-- | hpp runner that returns output lines. +hppIO :: Config -> Env -> FilePath -> [String] + -> IO (Either Error ([FilePath], [String])) +hppIO cfg env' fileName src = do + r <- newIORef id + let snk xs = modifyIORef r (. (xs++)) + hppIOSink' (cfg {curFileNameF = pure fileName}) env' snk src >>= \case + Left e -> return (Left e) + Right files -> Right . (files,) . ($ []) <$> readIORef r diff --git a/src/Hpp/Tokens.hs b/src/Hpp/Tokens.hs --- a/src/Hpp/Tokens.hs +++ b/src/Hpp/Tokens.hs @@ -72,6 +72,7 @@ , ('\'', 0x27), ('"', 0x22), ('?', 0x3F) ] data TokChar = TokSpace Char | TokQuote | TokDQuote + -- | Break a 'String' into space and non-whitespace runs. tokWords :: Stringy s => s -> [Token s] tokWords s = diff --git a/src/Hpp/Types.hs b/src/Hpp/Types.hs --- a/src/Hpp/Types.hs +++ b/src/Hpp/Types.hs @@ -1,6 +1,7 @@ {-# LANGUAGE FlexibleInstances, LambdaCase, Rank2Types #-} -- | The core types involved used by the pre-processor. module Hpp.Types where +import Control.Exception (Exception (..)) import Control.Monad (ap) import Control.Monad.IO.Class (MonadIO, liftIO) import Control.Monad.Trans.Class (MonadTrans, lift) @@ -22,8 +23,6 @@ type LineNum = Int -- | A macro binding environment. --- type Env = [(String, Macro)] --- type Env = M.Map String Macro type Env = T.Trie Macro -- * Changing the underlying string type @@ -47,6 +46,8 @@ | BadCommandLine P.String | RanOutOfInput deriving (Eq, Ord, Show) + +instance Exception Error -- | Hpp can raise various parsing errors. class HasError m where diff --git a/tests/AsLib.hs b/tests/AsLib.hs new file mode 100644 --- /dev/null +++ b/tests/AsLib.hs @@ -0,0 +1,48 @@ +{-# LANGUAGE LambdaCase, OverloadedStrings #-} +import Control.Monad.Trans.Except +import Data.ByteString.Char8 (ByteString) +import Data.Maybe (fromMaybe) +import Data.Monoid ((<>)) +import Hpp +import System.Exit + +sourceIfdef :: [ByteString] +sourceIfdef = [ "#ifdef FOO" + , "x = 42" + , "#else" + , "x = 99" + , "#endif" ] + +sourceArith1 :: ByteString -> [ByteString] +sourceArith1 s = [ "#define x 3" + , "#if 5 + x > " <> s + , "yay" + , "#else" + , "boo" + , "#endif" ] + +hppHelper :: HppState -> [ByteString] -> [ByteString] -> IO Bool +hppHelper st src expected = runExceptT (runHpp st (preprocess src)) >>= \case + Left e -> putStrLn ("Error running hpp: " ++ show e) >> return False + Right (res, _) -> if hppOutput res == expected + then return True + else do putStr ("Expected "++show expected++", got") + print (hppOutput res) + return False + +testElse :: IO Bool +testElse = hppHelper emptyHppState sourceIfdef ["x = 99\n","\n"] + +testIf :: IO Bool +testIf = hppHelper (fromMaybe (error "Preprocessor definition did not parse") + (addDefinition "FOO" "1" emptyHppState)) + sourceIfdef + ["x = 42\n","\n"] + +testArith1 :: IO Bool +testArith1 = (&&) <$> hppHelper emptyHppState (sourceArith1 "7") ["yay\n","\n"] + <*> hppHelper emptyHppState (sourceArith1 "8") ["boo\n","\n"] + +main :: IO () +main = do results <- sequenceA [testElse, testIf, testArith1] + if and results then exitWith ExitSuccess else exitWith (ExitFailure 1)