diff --git a/hpp.cabal b/hpp.cabal --- a/hpp.cabal +++ b/hpp.cabal @@ -1,5 +1,5 @@ name: hpp -version: 0.5.2 +version: 0.6.0 synopsis: A Haskell pre-processor description: See the README for usage examples license: BSD3 @@ -21,18 +21,23 @@ library exposed-modules: Hpp, Hpp.CmdLine, + Hpp.Conditional, Hpp.Config, + Hpp.Directive, Hpp.Env, Hpp.Expansion, Hpp.Expr, + Hpp.Macro, Hpp.Parser, + Hpp.Preprocessing, Hpp.RunHpp, Hpp.String, Hpp.StringSig, Hpp.Tokens, Hpp.Types - build-depends: base >=4.8 && <4.12, directory, time >=1.5, filepath, - transformers >=0.4, bytestring, bytestring-trie, ghc-prim + build-depends: base >=4.8 && <4.13, directory, time >=1.5, filepath, + transformers >=0.4, bytestring, unordered-containers, + ghc-prim if impl(ghc < 8) build-depends: semigroups >= 0.18 && < 0.19 diff --git a/src/Hpp.hs b/src/Hpp.hs --- a/src/Hpp.hs +++ b/src/Hpp.hs @@ -18,8 +18,10 @@ import Data.Maybe (fromMaybe) import qualified Hpp.Config as C import qualified Hpp.Env as E +import qualified Hpp.Macro as M import qualified Hpp.RunHpp as R import qualified Hpp.Types as T +import Hpp.Types (setL, config, env, lineNum) import Hpp.Parser (evalParse, Parser) import Hpp.StringSig (readLines) import Hpp.Tokens (tokenize) @@ -71,8 +73,7 @@ streamHpp st snk (HppT h) = do (a, st') <- S.runStateT (evalParse - (R.runHpp (T.hppConfig st) - (liftIO . readLines) + (R.runHpp (liftIO . readLines) (lift . lift . lift . snk) h) []) @@ -116,7 +117,7 @@ -- | 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 +initHppState c e = setL lineNum 1 . setL env e . setL config c $ emptyHppState -- | @addDefinition name expression@ adds a binding of @name@ to -- @expression@ in the preprocessor’s internal state. @@ -128,4 +129,4 @@ -- 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) +parseDefinition name val = M.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 @@ -2,7 +2,7 @@ -- | A front-end to run Hpp with textual arguments as from a command -- line invocation. module Hpp.CmdLine (runWithArgs) where -import Control.Monad (unless, (>=>)) +import Control.Monad (unless) import Control.Monad.Trans.Except (runExceptT) import Data.String (fromString) import Hpp @@ -89,7 +89,7 @@ return . Left $ BadCommandLine "Multiple output files given" -- | Run Hpp with the given commandline arguments. -runWithArgs :: [String] -> IO () +runWithArgs :: [String] -> IO (Maybe Error) runWithArgs args = do cfgNow <- defaultConfigFNow let args' = concatMap splitSwitches args @@ -108,16 +108,12 @@ flip openFile WriteMode return ( \os -> mapM_ (putStringy h) os , hClose h ) - let errorExcept = runExceptT >=> either (error . show) pure - _ <- 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') + result <- readLines fileName + >>= runExceptT + . streamHpp (initHppState cfg' env) snk + . preprocess + . (map fromString lns ++) closeSnk + case result of + Left err -> return $ Just err + _ -> return Nothing diff --git a/src/Hpp/Conditional.hs b/src/Hpp/Conditional.hs new file mode 100644 --- /dev/null +++ b/src/Hpp/Conditional.hs @@ -0,0 +1,82 @@ +{-# LANGUAGE BangPatterns, CPP, OverloadedStrings #-} +-- | Parsing functionality for pre-processor conditionals. +module Hpp.Conditional (dropBranch, takeBranch) where +#if __GLASGOW_HASKELL__ < 804 +import Data.Semigroup ((<>)) +#endif +import Data.String (fromString) +import Hpp.Parser (replace, awaitJust, Parser) +import Hpp.Tokens (notImportant, Token(..)) +import Hpp.Types (lineNum, use, HasHppState, HasError, LineNum, TOKEN, String) +import Prelude hiding (String) + +yieldLineNum :: LineNum -> [TOKEN] +yieldLineNum !ln = [Important ("#line " <> fromString (show ln)), Other "\n"] + +getCmd :: [TOKEN] -> Maybe String +getCmd = aux . dropWhile notImportant + where aux (Important "#" : ts) = case dropWhile notImportant ts of + (Important cmd:_) -> Just cmd + _ -> Nothing + aux _ = Nothing + +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). +takeBranch :: LineNum -> [[TOKEN]] -> [[TOKEN]] +takeBranch = 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 + +-- | Drop the rest of a conditional expression incrementing the given +-- 'LineNum' by the number of lines skipped. +dropBranch :: (HasError m, HasHppState m, Monad m) => Parser m [TOKEN] () +dropBranch = do ln <- use lineNum + (el, numSkipped) <- dropBranchAux + let ln' = ln + numSkipped + replace (yieldLineNum ln') + mapM_ replace el + +-- | 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. +dropBranchAux :: (HasError m, Monad m) => Parser m [TOKEN] (Maybe [TOKEN], Int) +dropBranchAux = 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) diff --git a/src/Hpp/Config.hs b/src/Hpp/Config.hs --- a/src/Hpp/Config.hs +++ b/src/Hpp/Config.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE StandaloneDeriving, FlexibleInstances #-} -- | Preprocessor Configuration module Hpp.Config where import Data.Functor.Identity @@ -47,6 +48,8 @@ -- | A fully-populated configuration for the pre-processor. type Config = ConfigF Identity + +deriving instance Show (ConfigF Identity) -- | Ensure that required configuration fields are supplied. realizeConfig :: ConfigF Maybe -> Maybe Config diff --git a/src/Hpp/Directive.hs b/src/Hpp/Directive.hs new file mode 100644 --- /dev/null +++ b/src/Hpp/Directive.hs @@ -0,0 +1,201 @@ +{-# LANGUAGE LambdaCase, OverloadedStrings, ScopedTypeVariables, + ViewPatterns #-} +-- | Implement the logic of CPP directives (commands prefixed with an +-- octothorpe). +module Hpp.Directive (directive, macroExpansion) where +import Control.Monad (unless) +import Control.Monad.Trans.Class (lift) +import Control.Monad.Trans.Except +import Control.Monad.Trans.State.Strict (StateT) +import Hpp.Conditional (dropBranch, takeBranch) +import Hpp.Config (curFileName, curFileNameF) +import Hpp.Env (lookupKey, deleteKey, insertPair) +import Hpp.Expansion (expandLineState) +import Hpp.Expr (evalExpr, parseExpr) +import Hpp.Macro (parseDefinition) +import Hpp.Preprocessing (prepareInput) +import Hpp.StringSig (unquote, toChars) +import Hpp.Tokens (newLine, notImportant, trimUnimportant, detokenize, isImportant, Token(..)) +import Hpp.Types +import Hpp.Parser (replace, await, insertInputSegment, takingWhile, droppingWhile, onInputSegment, evalParse, onElements, awaitJust, ParserT, Parser) +import Text.Read (readMaybe) +import Prelude hiding (String) + +-- | 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) + +droppingSpaces ::(Monad m) => ParserT m src TOKEN () +droppingSpaces = droppingWhile notImportant + +-- | 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 + -- NOTE: We should *NOT* use a the config lens here + -- because it will mutate the directory which + -- we *don't* want in this instance. + setState (st {hppConfig = cfg', hppLineNum = 1}) + return (cfg, ln) + insertInputSegment + s (getState >>= setState . setL lineNum oldLine . setL config oldCfg) + +-- | Handle preprocessor directives (commands prefixed with an octothorpe). +directive :: forall m. (Monad m, HasError m, HasHppState m, HasEnv 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 <$> expandLineState) + 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 dropBranch + Just _ -> + lift (onInputSegment (takeBranch 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 (takeBranch ln)) -- takeBranch ln >>= precede) + Just _ -> lift dropBranch + _ -> 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 + (toChars (detokenize (Important t:toks))) + 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 + <$> expandLineState) + 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 expandLineState [squashDefines e toks])) + let res = evalExpr <$> parseExpr (map (fmap toChars) ex) + lineNum .= ln + if maybe False (/= 0) res + then lift (onInputSegment (takeBranch ln)) -- (takeBranch ln >>= precede) + else lift dropBranch +{-# 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 + +-- | Expands an input line producing a stream of output lines. +macroExpansion :: (Monad m, HasHppState m, HasError m, HasEnv 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 <$> expandLineState)) <* (lineNum %= (+1)) diff --git a/src/Hpp/Env.hs b/src/Hpp/Env.hs --- a/src/Hpp/Env.hs +++ b/src/Hpp/Env.hs @@ -2,68 +2,17 @@ -- | A name binding context, or environment. module Hpp.Env where import Data.ByteString (ByteString) -import qualified Data.Trie as T - -emptyEnv :: T.Trie a -emptyEnv = T.empty - -insertPair :: (ByteString, a) -> T.Trie a -> T.Trie a -insertPair = uncurry T.insert - -deleteKey :: ByteString -> T.Trie a -> T.Trie a -deleteKey = T.delete - --- lookupKey :: L.ByteString -> T.Trie a -> Maybe (a, T.Trie a) --- lookupKey k t = (,t) <$> T.lookup (L.toStrict k) t -lookupKey :: ByteString -> T.Trie a -> Maybe a -lookupKey = T.lookup - - -{- -import qualified Data.Map as M - -emptyEnv :: M.Map String a -emptyEnv = M.empty -{-# INLINE emptyEnv #-} - -insertPair :: (String, a) -> M.Map String a -> M.Map String a -insertPair = uncurry M.insert -{-# INLINE insertPair #-} - -deleteKey :: String -> M.Map String a -> M.Map String a -deleteKey = M.delete -{-# INLINE deleteKey #-} +import Data.HashMap.Strict (HashMap) +import qualified Data.HashMap.Strict as HashMap -lookupKey :: String -> M.Map String a -> Maybe (a, M.Map String a) -lookupKey k m = fmap (\x -> (x, m)) (M.lookup k m) -{-# INLINE lookupKey #-} --} -{- --- | An empty binding environment. -emptyEnv :: [a] -emptyEnv = [] -{-# INLINE emptyEnv #-} +emptyEnv :: HashMap ByteString a +emptyEnv = HashMap.empty --- | Add a @(key,value)@ pair to an environment. -insertPair :: a -> [a] -> [a] -insertPair = (:) -{-# INLINE insertPair #-} +insertPair :: (ByteString, a) -> HashMap ByteString a -> HashMap ByteString a +insertPair = uncurry HashMap.insert --- | Delete an entry from an association list. -deleteKey :: Eq a => a -> [(a,b)] -> [(a,b)] -deleteKey k = go - where go [] = [] - go (h@(x,_) : xs) = if x == k then xs else h : go xs -{-# INLINE deleteKey #-} +deleteKey :: ByteString -> HashMap ByteString a -> HashMap ByteString a +deleteKey = HashMap.delete --- | Looks up a value in an association list. If the key is found, the --- value is returned along with an updated association list with that --- key at the front. -lookupKey :: Eq a => a -> [(a,b)] -> Maybe (b, [(a,b)]) -lookupKey k = go id - where go _ [] = Nothing - go acc (h@(x,v) : xs) - | k == x = Just (v, h : acc [] ++ xs) - | otherwise = go (acc . (h:)) xs -{-# INLINE lookupKey #-} --} +lookupKey :: ByteString -> HashMap ByteString a -> Maybe a +lookupKey = HashMap.lookup diff --git a/src/Hpp/Expansion.hs b/src/Hpp/Expansion.hs --- a/src/Hpp/Expansion.hs +++ b/src/Hpp/Expansion.hs @@ -2,7 +2,7 @@ -- | Line expansion is the core input token processing -- logic. Object-like macros are substituted, and function-like macro -- applications are expanded. -module Hpp.Expansion (expandLine) where +module Hpp.Expansion (expandLineState) where import Control.Monad.Trans.Class (lift) import Data.Bool (bool) import Data.Foldable (foldl', traverse_) @@ -17,7 +17,7 @@ onElements, droppingWhile, awaitJust, evalParse) import Hpp.StringSig (stringify, uncons, isEmpty, toChars) import Hpp.Tokens (Token(..), notImportant, isImportant, detokenize) -import Hpp.Types (HasError(..), HasEnv(..), Scan(..), Error(..), Macro(..), +import Hpp.Types (hppConfig, hppLineNum, getState, HasHppState, HasError(..), HasEnv(..), Scan(..), Error(..), Macro(..), TOKEN, String, lookupMacro) import Prelude hiding (String) @@ -32,6 +32,15 @@ isImportantScan :: Scan -> Bool isImportantScan = maybe False isImportant . unscan + +expandLineState :: (Monad m, HasHppState m, HasEnv m, HasError m) + => Parser m [TOKEN] [TOKEN] +expandLineState = + do st <- getState + let ln = hppLineNum st + cfg = hppConfig st + expandLine cfg ln + -- | Expand all macros to the end of the current line or until all -- in-progress macro invocations are complete, whichever comes last. diff --git a/src/Hpp/Macro.hs b/src/Hpp/Macro.hs new file mode 100644 --- /dev/null +++ b/src/Hpp/Macro.hs @@ -0,0 +1,98 @@ +{-# LANGUAGE CPP, OverloadedStrings, ViewPatterns #-} +module Hpp.Macro (parseDefinition) where +import Data.Char (isSpace) +#if __GLASGOW_HASKELL__ < 804 +import Data.Semigroup ((<>)) +#endif +import Hpp.StringSig +import Hpp.Tokens (trimUnimportant, importants, Token(..), isImportant) +import Hpp.Types (Macro(..), String, TOKEN, Scan(..)) +import Prelude hiding (String) + +-- * 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 + +-- | 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 + +-- * Function-like macros as Haskell functions + +-- | Drop spaces following @'#'@ characters. +prepStringify :: [TOKEN] -> [TOKEN] +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 + +-- | Concatenate tokens separated by @'##'@. +paste :: [Scan] -> [Scan] +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 + +-- | @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 (uncons -> Just ('#',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 + body' = prepStringify . prepTOKENSplices $ + dropWhile (not . isImportant) body diff --git a/src/Hpp/Parser.hs b/src/Hpp/Parser.hs --- a/src/Hpp/Parser.hs +++ b/src/Hpp/Parser.hs @@ -1,107 +1,94 @@ -{-# LANGUAGE LambdaCase, Rank2Types, TupleSections, ScopedTypeVariables #-} +{-# LANGUAGE DeriveFunctor, LambdaCase, TupleSections #-} -- | Parsers over streaming input. -module Hpp.Parser (Parser, ParserT, parse, evalParse, await, awaitJust, replace, - droppingWhile, precede, takingWhile, onChunks, onElements, - onInputSegment, insertInputSegment, onIsomorphism, - runParser) where -import Control.Arrow (second, (***)) +module Hpp.Parser (Parser, ParserT, evalParse, await, awaitJust, replace, + droppingWhile, precede, takingWhile, onElements, + onInputSegment, insertInputSegment, onIsomorphism) where +import Control.Arrow ((***)) import Control.Monad.Trans.State.Strict import Hpp.Types (HasError(..), Error(UserError)) import Control.Monad.Trans.Class (lift) import Data.List.NonEmpty (NonEmpty(..)) import Data.Maybe (mapMaybe) -import Data.Monoid ((<>)) -- * Parsers --- | Our input is a list of values each of which is either an action or a value. -type RopeM m a = [Either (m ()) a] +-- | A single pre-processor input is either an action or a value +data InputItem m a = Action (m ()) | Value a deriving Functor +-- | Our input is a list of values each of which is either an action +-- or a value. +type Input m a = [InputItem m a] + +-- | Functions for working with input sources. +data Source m src i = Source { srcSrc :: src + , _srcAwait :: src -> m (Maybe (i, src)) + , _srcPrecede :: [i] -> src -> src } + -- | A 'ParserT' is a bit of state that carries a source of input. -type ParserT m src i = StateT (Headspring m src i, src) m +type ParserT m src i = StateT (Source m src i) m -- | A 'Parser' is a bit of state that carries a source of input -- consisting of a list of values which are either actions in an -- underlying monad or sequences of inputs. Thus we have chunks of -- input values with interspersed effects. -type Parser m i = ParserT m (RopeM m [i]) i - -data Headspring m src i = - Headspring { hsAwait :: src -> m (Maybe (i, src)) - , hsPrecede :: [i] -> src -> src } +type Parser m i = ParserT m (Input m [i]) i -- | Pop the head non-effect element from a list. -unconsM :: Applicative m => RopeM m a -> m (Maybe (a, RopeM m a)) +unconsM :: Applicative m => Input m a -> m (Maybe (a, Input m a)) unconsM [] = pure Nothing -unconsM (Left m : ms) = m *> unconsM ms -unconsM (Right x : ms) = pure (Just (x, ms)) +unconsM (Action m : ms) = m *> unconsM ms +unconsM (Value x : ms) = pure (Just (x, ms)) -- | Pop the first non-null, non-effect element from a list. -unconsMNonEmpty :: Monad m => RopeM m [a] -> m (Maybe (NonEmpty a, RopeM m [a])) +unconsMNonEmpty :: Monad m => Input m [a] -> m (Maybe (NonEmpty a, Input m [a])) unconsMNonEmpty r = unconsM r >>= \case Nothing -> pure Nothing Just ([], rst) -> unconsMNonEmpty rst Just (x:xs, rst) -> return (Just (x :| xs, rst)) -unconsSpring :: Monad m => Headspring m (RopeM m [i]) i -unconsSpring = Headspring aw ropePrecede +unconsSource :: Monad m => Input m [i] -> Source m (Input m [i]) i +unconsSource src = Source src aw ropePrecede where aw r = unconsMNonEmpty r >>= \case Nothing -> return Nothing - Just (x :| xs, r') -> return (Just (x, Right xs : r')) + Just (x :| xs, r') -> return (Just (x, Value xs : r')) -flattenSpring :: Monad m => Headspring m (RopeM m [[i]]) i -flattenSpring = Headspring aw pr - where aw r = unconsMNonEmpty r >>= \case +flattenSource :: Monad m => Source m (Input m [[i]]) [i] -> Source m (Input m [[i]]) i +flattenSource (Source src0 aw pr) = Source src0 aw' pr' + where aw' src = aw src >>= \case Nothing -> return Nothing - Just ([] :| ys, r') -> aw (Right ys : r') - Just ((x:xs) :| ys, r') -> return (Just (x, Right (xs:ys) : r')) - pr xs [] = [Right [xs]] - pr xs (Right (ys:zs) : ms) = Right ((xs++ys) : zs) : ms - pr xs (Right [] : ms) = Right [xs] : ms - pr xs ms@(Left _ : _) = Right [xs] : ms - -chunkSpring :: (Monoid src, Applicative m) => Headspring m (RopeM m src) src -chunkSpring = Headspring unconsM pr - where pr xs [] = [Right (mconcat xs)] - pr xs (Right ys : ms) = Right (mconcat xs <> ys) : ms - pr xs ms@(Left _ : _) = Right (mconcat xs) : ms + Just ([], src') -> aw' src' + Just (x:xs, src') -> return (Just (x, pr' xs src')) + pr' xs src = pr [xs] src await :: Monad m => ParserT m src i (Maybe i) -await = do (hs, st) <- get - lift (hsAwait hs st) >>= \case +await = do Source src aw pr <- get + lift (aw src) >>= \case Nothing -> return Nothing - Just (x,st') -> Just x <$ put (hs,st') + Just (x, src') -> Just x <$ put (Source src' aw pr) {-# INLINE await #-} -- | Push a value back into a parser's source. replace :: (Monad m) => i -> ParserT m src i () replace = precede . pure -ropePrecede :: [i] -> RopeM m [i] -> RopeM m [i] -ropePrecede xs [] = [Right xs] -ropePrecede xs ms@(Left _ : _) = Right xs : ms -ropePrecede xs (Right ys : ms) = Right (xs++ys) : ms +ropePrecede :: [i] -> Input m [i] -> Input m [i] +ropePrecede xs [] = [Value xs] +ropePrecede xs ms@(Action _ : _) = Value xs : ms +ropePrecede xs (Value ys : ms) = Value (xs++ys) : ms -- | Push a stream of values back into a parser's source. precede :: Monad m => [i] -> ParserT m src i () -precede xs = do (hs,st) <- get - put (hs, hsPrecede hs xs st) +precede xs = do Source src aw pr <- get + put (Source (pr xs src) aw pr) {-# INLINE precede #-} --- | Run a 'Parser' with a given input stream. -parse :: Monad m => Parser m i o -> [i] -> m (o, RopeM m [i]) -parse m xs = second snd <$> runStateT m (unconsSpring, [Right xs]) -{-# INLINE parse #-} - -runParser :: Monad m => Parser m i o -> RopeM m [i] -> m (o, RopeM m [i]) -runParser m xs = second snd <$> runStateT m (unconsSpring, xs) - +-- | Evaluate a 'Parser' with a given input stream. evalParse :: Monad m => Parser m i o -> [i] -> m o -evalParse m xs = evalStateT m (unconsSpring, [Right xs]) +evalParse m xs = evalStateT m (unconsSource [Value xs]) -- * Operations on Parsers --- | 'awaitP' that throws an error with the given message if no more +-- | 'await' that throws an error with the given message if no more -- input is available. This may be used to locate where in a -- processing pipeline input was unexpectedly exhausted. awaitJust :: (Monad m, HasError m) => String -> ParserT m src i i @@ -131,43 +118,45 @@ | otherwise -> replace x >> return (acc []) {-# INLINE takingWhile #-} -insertInputSegment :: Monad m => src -> m () -> ParserT m (RopeM m src) i () -insertInputSegment xs k = modify' (second ([Right xs, Left k]++)) +insertInputSegment :: Monad m => src -> m () -> ParserT m (Input m src) i () +insertInputSegment xs k = + modify' (\s -> s { srcSrc = [Value xs, Action k] ++ srcSrc s}) -onInputSegment :: Monad m => (src -> src) -> ParserT m (RopeM m src) i () -onInputSegment f = do (hs,st) <- get - case st of - [] -> return () - (Right xs : ys) -> put (hs, Right (f xs) : ys) - (Left m : xs) -> lift m >> put (hs,xs) >> onInputSegment f +onInputSegment :: Monad m => (src -> src) -> ParserT m (Input m src) i () +onInputSegment f = + do Source src aw pr <- get + case src of + [] -> return () + (Value xs : ys) -> put (Source (Value (f xs) : ys) aw pr) + (Action m : xs) -> lift m >> put (Source xs aw pr) >> onInputSegment f {-# INLINABLE onInputSegment #-} -- * Parser Transformations -onChunks :: Monad m => ParserT m (RopeM m [i]) [i] r -> Parser m i r -onChunks m = do (hs,st) <- get - (r, (_,st')) <- lift (runStateT m (chunkSpring, st)) - r <$ put (hs,st') - -onElements :: Monad m => ParserT m (RopeM m [[i]]) i r -> Parser m [i] r -onElements m = do (hs,st) <- get - (r, (_,st')) <- lift (runStateT m (flattenSpring, st)) - let onHead _ [] = [] - onHead f (x:xs) = f x : xs - r <$ put (hs, onHead (fmap (dropWhile null)) st') +-- | A parser on lists of things can embed a parser on things. For +-- example, if we have a parser on lists of words, we can embed a +-- parser on individual words. +onElements :: Monad m => ParserT m (Input m [[i]]) i r -> Parser m [i] r +onElements m = do s@(Source _ aw pr) <- get + (r, Source src' _ _) <- lift (runStateT m (flattenSource s)) + r <$ put (Source (onHead (fmap (dropWhile null)) src') aw pr) + where onHead _ [] = [] + onHead f (x:xs) = f x : xs {-# INLINE onElements #-} -onIsomorphism :: forall m a b src r. Monad m - => (a -> b) -> (b -> Maybe a) +-- | Given a function with type @a -> b@, and a partial inverse, @b -> +-- Maybe a@, we can embed a parser on values of type @b@ in a parser +-- on values of type @a@. +onIsomorphism :: Monad m + => (a -> b) + -> (b -> Maybe a) -> ParserT m ([b],src) b r -> ParserT m src a r onIsomorphism fwd bwd m = - do (hs,st) <- get - let aw :: ([b],src) -> m (Maybe (b, ([b], src))) - aw ([], src) = fmap (fmap (fwd *** ([],))) (hsAwait hs src) - aw ((b:bs), src) = return (Just (b, (bs,src))) - pr xs (bs,src) = (xs++bs, src) - mappedSpring = Headspring aw pr - (r, (_, (bs, st'))) <- lift (runStateT m (mappedSpring, ([], st))) - r <$ put (hs, hsPrecede hs (mapMaybe bwd bs) st') + do Source src aw pr <- get + let aw' ([], src') = fmap (fmap (fwd *** ([],))) (aw src') + aw' ((b:bs), src') = return (Just (b, (bs,src'))) + pr' xs (bs, src') = (xs++bs, src') + (r, Source (bs, src') _ _) <- lift (runStateT m (Source ([],src) aw' pr')) + r <$ put (Source (pr (mapMaybe bwd bs) src') aw pr) {-# INLINE onIsomorphism #-} diff --git a/src/Hpp/Preprocessing.hs b/src/Hpp/Preprocessing.hs new file mode 100644 --- /dev/null +++ b/src/Hpp/Preprocessing.hs @@ -0,0 +1,157 @@ +{-# LANGUAGE BangPatterns, CPP, OverloadedStrings #-} +-- | The simplest pre-processing steps are represented as distinct +-- passes over input lines. +module Hpp.Preprocessing + ( + trigraphReplacement + , lineSplicing + , cCommentRemoval + , cCommentAndTrigraph + , prepareInput + ) where +import Control.Arrow (first) +import Data.Char (isSpace) +#if __GLASGOW_HASKELL__ < 804 +import Data.Semigroup ((<>)) +#endif +import Data.String (fromString) +import Hpp.Config +import Hpp.StringSig +import Hpp.Tokens (tokenize, Token(..), skipLiteral) +import Hpp.Types (TOKEN, String, HasHppState, getState, config, getL) +import Prelude hiding (String) + +-- * 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 + +-- | Remove C-style comments bracketed by @/*@ and @*/@. +cCommentRemoval :: Stringy s => [s] -> [s] +cCommentRemoval = removeMultilineComments 1 . map dropOneLineBlockComments + +-- | Remove C-style comments bracked by @/*@ and @*/@ and perform +-- trigraph replacement. +cCommentAndTrigraph :: Stringy s => [s] -> [s] +cCommentAndTrigraph = removeMultilineComments 1 + . map (dropOneLineBlockComments . trigraphReplacement) + +prepareInput :: (Monad m, HasHppState 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) + +-- * HPP configurations + +-- | Standard CPP settings for processing C files. +normalCPP :: [String] -> [[TOKEN]] +normalCPP = map ((++ [Other "\n"]) . tokenize) + . lineSplicing + . cCommentAndTrigraph +{-# INLINABLE normalCPP #-} + +-- | For Haskell we do not want trigraph replacement. +haskellCPP :: [String] -> [[TOKEN]] +haskellCPP = map ((++[Other "\n"]) . tokenize) + . lineSplicing + . cCommentRemoval +{-# 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 cCommentRemoval else id) + . (if replaceTrigraphs cfg then map trigraphReplacement else id) diff --git a/src/Hpp/RunHpp.hs b/src/Hpp/RunHpp.hs --- a/src/Hpp/RunHpp.hs +++ b/src/Hpp/RunHpp.hs @@ -1,236 +1,50 @@ {-# LANGUAGE BangPatterns, ConstraintKinds, LambdaCase, OverloadedStrings, ScopedTypeVariables, TupleSections, ViewPatterns #-} -- | Mid-level interface to the pre-processor. -module Hpp.RunHpp (parseDefinition, preprocess, runHpp, expandHpp, - hppIOSink, HppCaps, hppIO, HppResult(..)) where -import Control.Arrow (first) +module Hpp.RunHpp (preprocess, runHpp, expandHpp, + hppIOSink, hppIO, HppResult(..)) where import Control.Exception (throwIO) -import Control.Monad (unless, (>=>)) +import Control.Monad ((>=>)) 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, State) -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.Config (Config, curFileNameF, curFileName, includePaths, inhibitLinemarkers) +import Hpp.Directive (macroExpansion) +import Hpp.Parser (Parser, precede, evalParse) +import Hpp.Preprocessing import Hpp.StringSig -import Hpp.Tokens (Token(..), importants, isImportant, newLine, trimUnimportant, - detokenize, notImportant, tokenize, skipLiteral) +import Hpp.String (stripAngleBrackets) +import Hpp.Tokens (detokenize) 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 = +includeCandidates :: FilePath -> [FilePath] -> P.String -> Maybe [FilePath] +includeCandidates curDir searchPath nm = case nm of - '<':nm' -> Just $ sysSearch (init nm') + '<':nm' -> Just $ sysSearch (init nm') '"':nm' -> let nm'' = init nm' - in Just $ nm'' : sysSearch nm'' + in Just $ nm'' : localSearch nm'' _ -> Nothing - where sysSearch f = map ( f) searchPath + where sysSearch f = map ( f) searchPath + localSearch f = map ( f) $ curDir : searchPath -searchForInclude :: [FilePath] -> P.String -> IO (Maybe FilePath) -searchForInclude paths = maybe (return Nothing) aux . includeCandidates paths +searchForInclude :: FilePath -> [FilePath] -> P.String -> IO (Maybe FilePath) +searchForInclude curDir paths = + maybe (return Nothing) aux . includeCandidates curDir 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 +searchForNextInclude :: FilePath -> [FilePath] -> P.String -> IO (Maybe FilePath) +searchForNextInclude curDir paths = + maybe (return Nothing) (aux False) . includeCandidates curDir paths where aux _ [] = return Nothing aux n (f:fs) = do exists <- doesFileExist f if exists @@ -247,33 +61,38 @@ -- | Interpret the IO components of the preprocessor. This -- implementation relies on IO for the purpose of checking search -- paths for included files. -runHpp :: forall m a src. (MonadIO m) - => Config - -> (FilePath -> m src) +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 cfg source sink m = runHppT m >>= go [] +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 -> - liftIO (searchForInclude (includePaths cfg) file) - >>= readAux (file:files) ln file k - ReadNext ln file k -> - liftIO (searchForNextInclude (includePaths cfg) file) - >>= readAux (file:files) ln file k + ReadFile ln file k -> do + cfg <- use config + curDir <- use dir + let ipaths = includePaths cfg + mFound <- liftIO $ searchForInclude curDir ipaths file + readAux (file:files) ln file k mFound + ReadNext ln file k -> do + cfg <- use config + curDir <- use dir + let ipaths = includePaths cfg + mFound <- liftIO $ searchForNextInclude curDir ipaths file + readAux (file:files) ln file k mFound WriteOutput output k -> sink output >> runHppT k >>= go files readAux _files ln file _ Nothing = - pure (Left (curFileName cfg, IncludeDoesNotExist ln file)) + Left . (, IncludeDoesNotExist ln (stripAngleBrackets file)) + . curFileName <$> use config readAux files _ln _file k (Just file') = source file' >>= runHppT . k >>= go files {-# SPECIALIZE runHpp :: - Config - -> (FilePath -> Parser (StateT HppState (ExceptT Error IO)) [TOKEN] [String]) + (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)) #-} @@ -308,332 +127,17 @@ (ExceptT Error (State ([String] -> [String])))) [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) + Just o -> hppWriteOutput o >> go -- * 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) +preprocess :: (Monad m, HasHppState m, HasError m, HasEnv m) => [String] -> HppT [String] (Parser m [TOKEN]) () preprocess src = do cfg <- getL config <$> getState @@ -651,7 +155,7 @@ -- `ExceptT`, `StateT`, and `Parser` (note that `Parser` is actually -- just another `StateT`). --- | A concreate choice of types to satisfy `HppCaps` as required by +-- | A concreate choice of types to satisfy the constraints of -- `preprocess`. dischargeHppCaps :: Monad m => Config -> Env @@ -673,7 +177,7 @@ hppIOSink' cfg env' snk src = fmap (fmap hppFilesRead) . dischargeHppCaps cfg env' $ - runHpp cfg (liftIO . readLines) (liftIO . snk) (preprocess src) + 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 diff --git a/src/Hpp/String.hs b/src/Hpp/String.hs --- a/src/Hpp/String.hs +++ b/src/Hpp/String.hs @@ -1,6 +1,14 @@ {-# LANGUAGE BangPatterns #-} -- | HELPERS for working with 'String's -module Hpp.String (stringify, unquote, trimSpaces, breakOn, cons) where +module Hpp.String ( + stringify + , unquote + , stripAngleBrackets + , trimSpaces + , breakOn + , cons + ) + where import Data.Char (isSpace) import Data.List (isPrefixOf, find) @@ -16,11 +24,22 @@ -- | Remove double quote characters from the ends of a string. unquote :: String -> String -unquote ('"':xs) = go xs - where go ['"'] = [] +unquote = stripEnds '"' '"' + +-- | Remove angle brackets from the ends of a string. +stripAngleBrackets :: String -> String +stripAngleBrackets = stripEnds '<' '>' + +stripEnds :: Char -> Char -> String -> String +stripEnds start end s = + case s of + (start':rest) + | start == start' -> go rest + _ -> s + where go (c:[]) + | c == end = [] go [] = [] go (c:cs) = c : go cs -unquote xs = xs -- | Trim trailing spaces from a 'String' trimSpaces :: String -> String diff --git a/src/Hpp/StringSig.hs b/src/Hpp/StringSig.hs --- a/src/Hpp/StringSig.hs +++ b/src/Hpp/StringSig.hs @@ -1,11 +1,17 @@ {-# LANGUAGE BangPatterns, CPP, FlexibleInstances, OverloadedStrings, PatternSynonyms, TypeSynonymInstances, ViewPatterns #-} +-- | Defines a signature, 'Stringy', for string-like types that we may +-- want to use. module Hpp.StringSig where import Data.Char import qualified Data.List as L import Data.Maybe (isJust) +#if __GLASGOW_HASKELL__ < 804 +import Data.Semigroup (Semigroup) +#endif import Data.String (IsString) import qualified Hpp.String as S +import Data.ByteString (ByteString) import qualified Data.ByteString.Char8 as B import qualified Data.ByteString.Lazy.Char8 as BL import System.IO (Handle, hPutStr) @@ -13,7 +19,7 @@ data CharOrSub s = CharMatch !s !s | SubMatch !s !s | NoMatch -- | A collection of operations relating to sequences of characters. -class (IsString s, Monoid s) => Stringy s where +class (IsString s, Monoid s, Semigroup s) => Stringy s where -- | Stringification puts double quotes around a string and -- backslashes before existing double quote characters and backslash -- characters. @@ -175,7 +181,7 @@ sall = B.all sIsPrefixOf = B.isPrefixOf isEmpty = B.null - readLines = fmap (map BL.toStrict . BL.lines) . BL.readFile + readLines = fmap (map stripR . map BL.toStrict . BL.lines) . BL.readFile {-# INLINE readLines #-} putStringy = B.hPutStr toChars = B.unpack @@ -195,6 +201,12 @@ Nothing -> s Just (_, _, s') -> s' {-# INLINE sdropWhile #-} + +stripR :: ByteString -> ByteString +stripR bs + | not (B.null bs) && B.last bs == '\r' = B.init bs + | otherwise = bs +{-# INLINE stripR #-} #if __GLASGOW_HASKELL__ >= 800 pattern (:.) :: Stringy s => Char -> s -> s diff --git a/src/Hpp/Tokens.hs b/src/Hpp/Tokens.hs --- a/src/Hpp/Tokens.hs +++ b/src/Hpp/Tokens.hs @@ -95,7 +95,16 @@ '\\' :. cs -> case sbreak (boolJust . (== '\'')) cs of Nothing -> [Important (pre' <> pos)] - Just (_,esc,pos') -> + + Just (_,esc,pos') + | isEmpty esc -> + case sbreak (boolJust . (== '\'')) pos' of + Just (_,esc', pos'') + | isEmpty esc' -> + Important pre : Important ("'\\\''") : tokWords pos'' + -- Important (fromJust $ escapeChar '\'') : tokWords pos'' + _ -> [Important (pre' <> pos)] + | otherwise -> let esc' = if sall isOctDigit esc then Important (digitsFromBase 8 esc) else case esc of @@ -127,6 +136,9 @@ {-# INLINABLE tokWords #-} data LitStringChar = DBackSlash | EscapedDQuote | DQuote + +-- | Skip over a string or character literal returning the literal and +-- the remaining the input. skipLiteral :: Stringy s => s -> (s,s) skipLiteral s = case breakOn [("\\\\", DBackSlash), ("\\\"", EscapedDQuote), ("\"", DQuote)] s of diff --git a/src/Hpp/Types.hs b/src/Hpp/Types.hs --- a/src/Hpp/Types.hs +++ b/src/Hpp/Types.hs @@ -11,19 +11,20 @@ import Data.Functor.Constant import Data.Functor.Identity -- import qualified Data.Map as M -import qualified Data.Trie as T +import Data.HashMap.Strict (HashMap) import Hpp.Config import Hpp.Env (emptyEnv, lookupKey) import Hpp.StringSig (toChars) import Hpp.Tokens import Prelude hiding (String) import qualified Prelude as P +import System.FilePath (takeDirectory) -- | Line numbers are represented as 'Int's type LineNum = Int -- | A macro binding environment. -type Env = T.Trie Macro +type Env = HashMap ByteString Macro -- * Changing the underlying string type type String = ByteString @@ -86,11 +87,14 @@ -- | Dynamic state of the preprocessor engine. data HppState = HppState { hppConfig :: Config -- ^ Initial configuration + , hppCurDir :: FilePath + -- ^ Directory of input file , hppLineNum :: LineNum -- ^ Current line number of input file , hppEnv :: Env -- ^ Preprocessor binding environment } + deriving Show -- | A free monad construction to strictly delimit what capabilities -- we need to perform pre-processing. @@ -104,15 +108,30 @@ fmap f (WriteOutput o k) = WriteOutput o (f k) {-# INLINE fmap #-} +-- | 'Hpp' is a monad with 'HppF' as its base functor. +type Hpp t = FreeF (HppF t) + -- * Hpp Monad Transformer -- | A free monad transformer specialized to HppF as the base functor. -newtype HppT t m a = HppT { runHppT :: m (FreeF (HppF t) a (HppT t m a)) } +newtype HppT t m a = HppT { runHppT :: m (Hpp t a (HppT t m a)) } -writeOutput :: Monad m => t -> HppT t m () -writeOutput = HppT . return . FreeF . flip WriteOutput (return ()) -{-# INLINE writeOutput #-} +-- | @hppReadFile lineNumber fileName@ introduces an @#include +-- @ at the given line number. +hppReadFile :: Monad m => Int -> FilePath -> HppT src m src +hppReadFile n file = HppT (pure (FreeF (ReadFile n file return))) +{-# INLINE hppReadFile #-} +-- | @hppReadNext lineNumber fileName@ introduces an @#include_next +-- @ at the given line number. +hppReadNext :: Monad m => Int -> FilePath -> HppT src m src +hppReadNext n file = HppT (pure (FreeF (ReadNext n file return))) +{-# INLINE hppReadNext #-} + +hppWriteOutput :: Monad m => t -> HppT t m () +hppWriteOutput = HppT . return . FreeF . flip WriteOutput (return ()) +{-# INLINE hppWriteOutput #-} + instance Functor m => Functor (HppT t m) where fmap f (HppT x) = HppT $ fmap f' x where f' (PureF y) = PureF (f y) @@ -252,18 +271,24 @@ -- * State Lenses emptyHppState :: Config -> HppState -emptyHppState cfg = HppState cfg 1 emptyEnv +emptyHppState cfg = HppState cfg (takeDirectory (curFileName cfg)) 1 emptyEnv config :: Lens HppState Config -config f (HppState cfg ln e) = (\cfg' -> HppState cfg' ln e) <$> f cfg +config f (HppState cfg _dir ln e) = + (\cfg' -> HppState cfg' (takeDirectory (curFileName cfg')) ln e) <$> f cfg {-# INLINE config #-} +dir :: Lens HppState FilePath +dir f (HppState cfg dirOld ln e) = + (\dirNew -> HppState cfg dirNew ln e) <$> f dirOld +{-# INLINE dir #-} + lineNum :: Lens HppState LineNum -lineNum f (HppState cfg ln e) = (\ln' -> HppState cfg ln' e) <$> f ln +lineNum f (HppState cfg dir0 ln e) = (\ln' -> HppState cfg dir0 ln' e) <$> f ln {-# INLINE lineNum #-} env :: Lens HppState Env -env f (HppState cfg ln e) = (\e' -> HppState cfg ln e') <$> f e +env f (HppState cfg dir0 ln e) = (\e' -> HppState cfg dir0 ln e') <$> f e {-# INLINE env #-} use :: (HasHppState m, Functor m) => Lens HppState a -> m a diff --git a/src/Main.hs b/src/Main.hs --- a/src/Main.hs +++ b/src/Main.hs @@ -40,7 +40,7 @@ main :: IO () main = do getArgs >>= \case [] -> usage - args -> runWithArgs args + args -> runWithArgs args >> return () {-