hpp 0.5.2 → 0.6.0

raw patch · 17 files changed

+788/−726 lines, 17 filesdep +unordered-containersdep −bytestring-triedep ~basePVP ok

version bump matches the API change (PVP)

Dependencies added: unordered-containers

Dependencies removed: bytestring-trie

Dependency ranges changed: base

API changes (from Hackage documentation)

Files

• hpp.cabal +8/−3
• src/Hpp.hs +5/−4
• src/Hpp/CmdLine.hs +10/−14
• src/Hpp/Conditional.hs +82/−0
• src/Hpp/Config.hs +3/−0
• src/Hpp/Directive.hs +201/−0
• src/Hpp/Env.hs +10/−61
• src/Hpp/Expansion.hs +11/−2
• src/Hpp/Macro.hs +98/−0
• src/Hpp/Parser.hs +74/−85
• src/Hpp/Preprocessing.hs +157/−0
• src/Hpp/RunHpp.hs +43/−539
• src/Hpp/String.hs +23/−4
• src/Hpp/StringSig.hs +14/−2
• src/Hpp/Tokens.hs +13/−1
• src/Hpp/Types.hs +35/−10
• src/Main.hs +1/−1

@@ -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

@@ -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)

@@ -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

@@ -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)

@@ -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

@@ -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))

@@ -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

@@ -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.

@@ -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

@@ -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 #-}

@@ -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)

@@ -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--- <fileName>@ 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--- <fileName>@ 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

@@ -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

@@ -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

@@ -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

@@ -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+-- <fileName>@ 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+-- <fileName>@ 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

@@ -40,7 +40,7 @@ main :: IO () main = do getArgs >>= \case             [] -> usage-            args -> runWithArgs args+            args -> runWithArgs args >> return ()   {-