hpp 0.1.0.0 → 0.3.0.0

raw patch · 15 files changed

+1677/−672 lines, 15 filesdep ~basedep ~transformersPVP ok

version bump matches the API change (PVP)

Dependency ranges changed: base, transformers

API changes (from Hackage documentation)

Files

• CHANGELOG.md +21/−0
• hpp.cabal +12/−9
• src/Hpp.hs +482/−331
• src/Hpp/CmdLine.hs +100/−0
• src/Hpp/Config.hs +7/−3
• src/Hpp/Env.hs +31/−3
• src/Hpp/Expansion.hs +151/−135
• src/Hpp/Expr.hs +110/−34
• src/Hpp/Parser.hs +153/−0
• src/Hpp/StreamIO.hs +70/−0
• src/Hpp/Streamer.hs +356/−0
• src/Hpp/String.hs +21/−2
• src/Hpp/Tokens.hs +23/−4
• src/Hpp/Types.hs +134/−52
• src/Main.hs +6/−99

@@ -1,3 +1,24 @@+# 0.3++Switch to a stream processing model.++This library is designed to have minimal dependencies, so we now have+a bespoke implementation of a cross between the pipes and machines+libraries included.++This change was done to make some parsing+operations easier, believe it or not. For example, most pre-processing+is done on a line-by-line basis, but we must also support macro+function applications that cross line boundaries. Thus the expansion+logic can not merely be given one line at a time from an input+file. Previously, a heuristic tried to combine consecutive lines+before the parsing stage. Now, the parser itself is able to pull+tokens in across lines when necessary.++TL;DR: The upshot is that processing `/usr/include/stdio.h` on OS X (a+surprisingly complicated file!)  now uses 78% of the time and 0.38%+the memory of previous versions of `hpp`.+ # 0.1  First release!

@@ -1,5 +1,5 @@ name:                hpp-version:             0.1.0.0+version:             0.3.0.0 synopsis:            A Haskell pre-processor  description: @hpp@ is a Haskell pre-processor that is also a@@ -50,27 +50,30 @@   type:     git   location: http://github.com/acowley/hpp.git - library   exposed-modules:     Hpp,+                       Hpp.CmdLine,                        Hpp.Config,                        Hpp.Env,                        Hpp.Expansion,                        Hpp.Expr,+                       Hpp.Parser,+                       Hpp.Streamer,+                       Hpp.StreamIO,                        Hpp.String,                        Hpp.Tokens,                        Hpp.Types-  build-depends:       base >=4.7 && <4.9, directory, time, filepath-  if impl(ghc < 7.10)-    build-depends: transformers+  build-depends:       base >=4.7 && <4.10, directory, time, filepath,+                       transformers   hs-source-dirs:      src   default-language:    Haskell2010-  ghc-options: -Wall+  ghc-options: -Wall -fno-full-laziness+  -- ghc-options: -Wall -fprof-auto -fno-full-laziness -ddump-simpl -ddump-to-file+--  -ddump-simpl-stats  executable hpp   main-is:             src/Main.hs-  -- other-extensions:    -  build-depends:       hpp, base >=4.7 && <4.9, directory, time, filepath+  build-depends:       hpp, base >=4.7 && <4.10, directory, time, filepath   hs-source-dirs:      .   default-language:    Haskell2010-  ghc-options: -Wall -O2+  ghc-options: -Wall

@@ -1,25 +1,40 @@-{-# LANGUAGE LambdaCase, ScopedTypeVariables #-}+{-# LANGUAGE BangPatterns, ConstraintKinds, LambdaCase, RankNTypes,+             ScopedTypeVariables, GeneralizedNewtypeDeriving #-} -- | Front-end interface to the pre-processor.-module Hpp (parseDefinition, preprocess,-            liftHpp, errorHpp, getConfig, setConfig, hppReadFile,-            runErrHppIO) where-import Control.Arrow (second)-import Control.Exception (catch, IOException)-import Control.Monad ((<=<))+module Hpp (parseDefinition, preprocess, yield, before, source,+            hppReadFile, hppIO, hppRegisterCleanup,+            streamHpp, sinkToFile, sinkToStdOut, (~>), HppCaps) where+import Control.Applicative (empty)+import Control.Monad (unless)+import Control.Monad.IO.Class (MonadIO, liftIO)+import Control.Monad.Trans.State.Strict (runStateT) import Data.Char (isSpace)+import Data.Foldable (traverse_)+import Data.Functor.Constant import Data.Functor.Identity+import Data.List (isPrefixOf, uncons)+import Data.Monoid ((<>))+import Data.Void (Void)+import Hpp.Config (Config, curFileNameF, curFileName, includePaths,+                   eraseCComments, spliceLongLines, inhibitLinemarkers)+import Hpp.Env (deleteKey, emptyEnv, insertPair, lookupKey)+import Hpp.Expansion (expandLine)+import Hpp.Expr (evalExpr, parseExpr)+import Hpp.Parser (Parser(..), zoomParseChunks, replace, awaitP, awaitJust,+                   droppingWhile, liftP, parse, onParserSource, precede,+                   takingWhile)+import Hpp.StreamIO (sinkToFile, sinkToStdOut, sourceFile)+import Hpp.Streamer (Streamer(..), Chunky(..), metamorph, done, yields, mapping,+                     (~>), Source, before, liftS, source, encase, StreamStep(..),+                     yield, filtering, run)+import Hpp.String (stringify, trimSpaces, unquote, cons, breakOn)+import Hpp.Tokens (Token(..), importants, isImportant, newLine, trimUnimportant,+                   detokenize, notImportant, tokenize, skipLiteral)+import Hpp.Types import System.Directory (doesFileExist) import System.FilePath ((</>)) import Text.Read (readMaybe) -import Hpp.Config-import Hpp.Env-import Hpp.Expansion-import Hpp.Expr-import Hpp.String-import Hpp.Tokens-import Hpp.Types- -- * Trigraphs  -- | The first component of each pair represents the end of a known@@ -37,60 +52,40 @@             , ('>', '}')             , ('-', '~') ] --- | Count the prefix @?@ characters as we go.-data TrigraphPrefix = TP0 | TP1 | TP2 deriving (Enum, Show)- trigraphReplacement :: String -> String-trigraphReplacement = go TP0-  where go :: TrigraphPrefix -> String -> String-        go n [] = replicate (fromEnum n) '?'-        go TP2 ('?':xs) = '?' : go TP2 xs-        go TP2 (x:xs) = case lookup x trigraphs of-                          Just x' -> x' : go TP0 xs-                          Nothing -> "??" ++ x : go TP0 xs-        go i ('?':xs) = go (succ i) xs-        go TP0 (x:xs) = x : go TP0 xs-        go TP1 (x:xs) = '?' : x : go TP0 xs+trigraphReplacement = aux . breakOn "??"+  where aux (s,[]) = s+        aux (h,t) =+          case uncons (drop 2 t) of+            Nothing -> h <> "??"+            Just (c,t') -> +              case lookup c trigraphs of+                Just c' -> h <> cons c' (trigraphReplacement t')+                Nothing -> h <> "?" <> trigraphReplacement (cons '?' (cons c t'))  -- * Line Splicing -lineSplicing :: [String] -> [String]-lineSplicing [] = []-lineSplicing [x] = [x]-lineSplicing ([]:t) = [] : lineSplicing t-lineSplicing (x:t@(y:xs))-  | last x == '\\' = lineSplicing ((init x++y) : xs)-  | otherwise = x : lineSplicing t---- FIXME: This doesn't work! we can also end or start a line with an--- operator! A #pragma line shouldn't be spliced. But note also that--- treating a close parenthesis is risky.+-- | Yields full lines of input.+-- lineStream :: Monad m => Streamer m String String ()+-- lineStream = go id+--   where go acc = awaitMaybe (yield (acc [])) (yieldLines acc)+--         yieldLines acc s = case break (== '\n') s of+--                              (h,t) -> case t of+--                                         [] -> go (acc . (h++))+--                                         ['\n'] -> encase $ Yield (acc h) (go id)+--                                         (_:t') -> encase $+--                                                   Yield (acc h)+--                                                         (yieldLines id t') --- | Applications can run across multiple lines. We join those lines--- to simplify subsequent parsing. We simply look for trailing or--- leading commas to determine which lines to splice.-spliceApplications :: [String] -> [String]-spliceApplications = go Nothing-  where go :: Maybe String -> [String] -> [String]-        go prev [] = maybe [] (:[]) prev-        go prev (l:ls)-          | headIs '#' l = let p = maybe [] (:[]) prev-                           in p ++ l : go Nothing ls-        go (Just prev) (l:ls)-          | headOp opStarts l = go Nothing ((prev++l) : ls)-          | otherwise = prev : go Nothing (l:ls)-        go Nothing (l1:l2:ls)-          | headOp opEnds $ reverse l1 = go Nothing ((l1++l2):ls)-        go Nothing (l:ls) = go (Just l) ls- -        opEnds = [',','+','-','*','/','(','=','%','&','|','^']-        opStarts = [',','+','-','*','/','(',')','=','%','&','|','^']-        headOp ops xs = case dropWhile isSpace xs of-                          c:_ -> c `elem` ops-                          _ -> False-        headIs x xs = case dropWhile isSpace xs of-                        (y:_) -> y == x-                        _ -> False+-- | If a line ends with a backslash, it is prepended to the following+-- the line.+lineSplicing :: Monad m => Streamer m String String ()+lineSplicing = metamorph (Chunky go)+  where go [] = yields [] (done $ Chunky go)+        go ln = case last ln of+                  '\\' -> done . Chunky $ go . (init ln ++)+                  _ -> yields ln (done $ Chunky go)+{-# INLINE lineSplicing #-}  -- * C Comments @@ -113,39 +108,45 @@   c : skipLiteral (\x y -> x [] ++ dropOneLineBlockComments y) cs dropOneLineBlockComments ('/':'*':cs) = go cs   where go [] = "/*"-        go ('*':'/':t) = ' ' : dropOneLineBlockComments t+        go ('*':'/':t)+          | all isSpace t = t+          | otherwise = ' ' : dropOneLineBlockComments t         go (_:t) = go t dropOneLineBlockComments (c:cs) = c : dropOneLineBlockComments cs  dropLineComments :: String -> String-dropLineComments [] = []-dropLineComments ('/':'/':_) = []-dropLineComments (c:cs) = c : dropLineComments cs+dropLineComments = fst . breakOn "//" -removeMultilineComments :: Int -> [String] -> [String]-removeMultilineComments _ [] = []-removeMultilineComments lineNum (l:ls) =-  case breakBlockCommentStart l of-    Nothing -> l : removeMultilineComments (lineNum+1) ls-    Just (pre,_) ->-      case go 0 ls of-        (numSkipped, []) -> pre : replicate (lineNum+numSkipped) []-        (numSkipped, (l':ls')) -> -          let lineNum' = lineNum + numSkipped-          in (pre ++ l') : ("#line " ++ show (lineNum'+1))-             : removeMultilineComments lineNum' ls'-  where go :: Int -> [String] -> (Int, [String])-        go numSkipped [] = (numSkipped, [])-        go numSkipped (l':ls') =-          case breakBlockCommentEnd l' of-            Nothing -> go (numSkipped + 1) ls'-            Just rst -> (numSkipped+1, rst : ls')+removeMultilineComments :: Monad m => Int -> Streamer m String String ()+removeMultilineComments !lineStart = metamorph (Chunky $ goStart lineStart)+  where goStart !curLine ln =+          case breakBlockCommentStart ln of+            Nothing -> yields ln (done . Chunky $ goStart (curLine+1))+            Just (pre,_) -> done . Chunky $ goEnd (curLine+1) pre+        goEnd !curLine pre ln =+          case breakBlockCommentEnd ln of+            Nothing -> done (Chunky $ goEnd (curLine+1) pre)+            Just pos+              | all isSpace (pre++pos) ->+                yields ("#line "++show (curLine+1))+                       (done . Chunky . goStart $ curLine + 1)+              | otherwise -> yields (pre++pos) $+                             yields ("#line "++show (curLine+1))+                                    (done . Chunky $ goStart (curLine+1)) -commentRemoval :: [String] -> [String]-commentRemoval = map dropLineComments-               . removeMultilineComments 1-               . map dropOneLineBlockComments+              -- FIXME: The #line command interferes here, but the+              -- strategy above fails when multi-line comments end and+              -- begin on the same line. +              -- yields ("#line "++show curLine)+              --        (goStart (curLine+1) (pre++pos))+{-# INLINE removeMultilineComments #-}++commentRemoval :: Monad m => Streamer m String String ()+commentRemoval =  mapping dropOneLineBlockComments+               ~> removeMultilineComments 1+               ~> mapping dropLineComments+ -- * Token Splices  -- | Deal with the two-character '##' token pasting/splicing@@ -172,6 +173,7 @@ functionMacro :: [String] -> [Token] -> [([Scan],String)] -> [Scan] functionMacro params body = paste                           . subst body'+                          -- . M.fromList                           . zip params   where subst toks gamma = go toks           where go [] = []@@ -212,43 +214,35 @@  -- * Pre-Processor Capabilities --- | Raise an error condition.-errorHpp :: Error -> ErrHpp a-errorHpp e = do f <- liftHpp . fmap curFileName $ getConfig-                ErrHpp . pure $ Left (f, e)---- | Lift an 'Either' into an 'ErrHpp'-liftEither :: Either Error a -> ErrHpp a-liftEither = either errorHpp pure---- | Lift an 'Hpp' into an 'ErrHpp'-liftHpp :: Hpp a -> ErrHpp a-liftHpp = ErrHpp . fmap Right+config :: Lens HppState Config+config f (HppState cfg ln cln e) = (\cfg' -> HppState cfg' ln cln e) <$> f cfg --- | Read a file as an 'Hpp' action-hppReadFile :: Int -> FilePath -> Hpp String-hppReadFile n file = ReadFile n file return+lineNum :: Lens HppState LineNum+lineNum f (HppState cfg ln cln e) = (\ln' -> HppState cfg ln' cln e) <$> f ln --- | Read a file available on the search path after the path--- containing the current file.-hppReadNext :: Int -> FilePath -> Hpp String-hppReadNext n file = ReadNext n file return+cleanups :: Lens HppState [Cleanup]+cleanups f (HppState cfg ln cln e) = (\cln' -> HppState cfg ln cln' e) <$> f cln --- | Obtain the current 'Config'-getConfig :: Hpp Config-getConfig = GetConfig return+env :: Lens HppState Env+env f (HppState cfg ln cln e) = (\e' -> HppState cfg ln cln e') <$> f e --- | Set the current 'Config'-setConfig :: Config -> Hpp ()-setConfig = flip SetConfig (return ())+modifyState :: (Monad m, HasHppState m) => (HppState -> HppState) -> m ()+modifyState f = getState >>= setState . f --- | Run an action with a substitute 'Config'-withConfig :: Config -> ErrHpp a -> ErrHpp a-withConfig cfg m = do oldCfg <- liftHpp getConfig-                      liftHpp $ setConfig cfg-                      r <- m-                      liftHpp $ setConfig oldCfg-                      return r+-- | Run a Stream with a configuration for a new file.+streamNewFile :: (Monad m, HasHppState m)+              => FilePath+              -> Source m o ()+              -> Source m o ()+streamNewFile fp s = Streamer $+  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)+     runStream $+       before s (liftS $ modifyState (setL lineNum oldLine . setL config oldCfg))  -- * Running an Hpp Action @@ -278,23 +272,32 @@                                else aux True fs                           else aux n fs -runHpp :: Config -> Hpp a -> IO (Either (FilePath,Error) a)-runHpp cfg = go-  where go (Pure x) = return (Right x)-        go (ReadFile ln file k) = searchForInclude (includePaths cfg) file-                                  >>= readAux ln file k-        go (ReadNext ln file k) = searchForNextInclude (includePaths cfg) file-                                  >>= readAux ln file k-        go (GetConfig k) = go (k cfg)-        go (SetConfig cfg' k) = runHpp cfg' k+runHpp :: forall m a. MonadIO m+       => (FilePath -> HppStream m (InputStream (HppStream m)))+       -> HppState+       -> HppStream m a+       -> m (Either (FilePath,Error) (a, HppState))+runHpp readInput !st (HppStream m) = runHppT m >>= go+  where go :: FreeF (HppF (Source (HppStream m) String ()))+                    a+                    (HppT (InputStream (HppStream m)) m a)+           -> m (Either (FilePath, Error) (a, HppState))+        go (PureF x) = return $ Right (x,st)+        go (FreeF s) = case s of+          ReadFile ln file k ->+            liftIO (searchForInclude (includePaths cfg) file)+            >>= readAux ln file (HppStream . k)+          ReadNext ln file k ->+            liftIO (searchForNextInclude (includePaths cfg) file)+            >>= readAux ln file (HppStream . k)+          GetState k -> runHpp readInput st (HppStream $ k st)+          SetState st' k -> runHpp readInput st' (HppStream k)+          ThrowError e -> return $ Left (curFile, e)         curFile = curFileName cfg         readAux ln file _ Nothing =           return $ Left (curFile, IncludeDoesNotExist ln file)-        readAux ln file k (Just file') =-          catch (Just <$> readFile file')-                (\(_::IOException) -> return Nothing)-          >>= maybe (return . Left $ (curFile, FailedInclude ln file))-                    (go . k)+        readAux _ln _file k (Just file') = runHpp readInput st (readInput file' >>= k)+        cfg = hppConfig st  -- * Preprocessor @@ -316,224 +319,372 @@       in Just (name, Object rhs)     _ -> Nothing --- | Trim 'Other' 'Token's from both ends of a list of 'Token's.-trimUnimportant :: [Token] -> [Token]-trimUnimportant = aux id . dropWhile (not .isImportant)-  where aux _ [] = []-        aux acc (t@(Important _) : ts) = acc (t : aux id ts)-        aux acc (t@(Other _) : ts) = aux (acc . (t:)) ts+-- | 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 = 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+              ln <$ incLine --- | Handle preprocessor directives (commands prefixed with an octothorpe).-directive :: Config -> LineNum -> String-          -> ErrHpp ((LineNum -> [String] -> Config -> Env-                       -> [String] -> ErrHpp r)-                     -> Env -> [String] -> ErrHpp r)-directive cfg ln s =-  case importants toks of-    "pragma":_ -> pure $ \k -> k ln' [] cfg -- Pragmas are ignored-    "define":_ -> case parseDefinition . tail $-                       dropWhile (/= Important "define") toks of-                    Nothing -> errorHpp $ BadMacroDefinition ln-                    Just def -> pure $ \k -> k ln' [] cfg . (def :)-    ["undef",name] -> pure $ \k -> k ln' [] cfg . deleteKey name+dropLine :: (Monad m, HasError m, HasHppState m) => Parser m Token ()+dropLine = do droppingWhile (not . newLine)+              eat <- awaitJust "dropLine" -- Eat the newline character+              case eat of+                Other "\n" -> return ()+                wat -> error $ "Expected dropped newline: "++show wat+              incLine -    "include":_ -> includeAux hppReadFile . trimUnimportant . tail-                   $ dropWhile (/= Important "include") toks+-- * Nano-lens -    "include_next":_ -> includeAux hppReadNext . trimUnimportant . tail-                        $ dropWhile (/= Important "include_next") toks-            -    ("line":_) ->-      pure $ \k env lns ->-        do (env',rst) <- liftEither . expandLine cfg ln env . tail-                         $ dropWhile (/= Important "line") toks-           case dropWhile (not . isImportant) rst of-             Important n:optFile ->-               case readMaybe n of-                 Nothing -> errorHpp $ BadLineArgument ln n-                 Just ln'' ->-                   let cfg' = case optFile of-                                [] -> cfg-                                _ -> let f = unquote-                                           . detokenize-                                           . dropWhile (not . isImportant)-                                           . tail -- line number token-                                           . dropWhile (not . isImportant)-                                           $ rst-                                     in cfg { curFileNameF = pure f }-                   in k ln'' [] cfg' env' lns-             _ -> errorHpp $ BadLineArgument ln s-    ["ifdef", x] -> pure $ \k env lns ->-                    case lookupKey x env of-                      Nothing -> do lns' <- liftEither $ dropBranch lns-                                    k ln [] cfg env lns'-                      Just _ -> liftEither (takeBranch lns) >>= k ln [] cfg env-    ["ifndef", x] -> pure $ \k env lns ->-                     case lookupKey x env of-                       Nothing -> liftEither (takeBranch lns)-                                  >>= k ln [] cfg env-                       Just (_,env') -> do lns' <- liftEither $ dropBranch lns-                                           k ln [] cfg env' lns'-    ["else"] -> pure $ \k env lns ->-                liftEither (takeBranch lns) >>= k ln [] cfg env+type Lens s a = forall f. Functor f => (a -> f a) -> s -> f s -    "if":_ -> pure $ ifAux "if"-    "elif":_ -> pure $ ifAux "elif"-    ["endif"] -> pure $ \k env -> k ln [] cfg env-    "error":_ -> errorHpp . UserError ln . detokenize-                 . dropWhile (not . isImportant) . tail-                 $ dropWhile (/= Important "error") toks-    "warning":_ -> pure $ \k env -> k ln' [] cfg env -- FIXME-    _ -> errorHpp $ UnknownCommand ln s-  where toks = tokenize s-        ln' = ln + 1-        toksAfterCommand cmd = tail $ dropWhile (/= Important cmd) toks+setL :: Lens s a -> a -> s -> s+setL l x = runIdentity . l (const $ Identity x) -        ifAux c k env lns =-          do (env',ex) <- liftEither . expandLine cfg ln env . squashDefines env-                          $ toksAfterCommand c-             let res = evalExpr <$> parseExpr ex-                 -- res' = (if curFileName cfg == "test"-                 --          then trace ("Eval "++show ex++" => "++show res)-                 --          else id) res-             if maybe False (/= 0) res-               then either errorHpp (k ln [] cfg env') (takeBranch lns)-               else either errorHpp (k ln [] cfg env') (dropBranch lns)-        includeAux readFun fileToks = pure $ \k env lns ->-         do (env', fileName) <- liftEither $ expandLine cfg ln env fileToks-            let fileName' = detokenize $ trimUnimportant fileName-                cfg' = -- trace ("Including "++show fileName') $-                       cfg { curFileNameF = pure $ unquote fileName' }-            (env'',inc) <- liftHpp (readFun ln fileName')-                           >>= withConfig cfg' . preprocess env'-            k ln' [inc] cfg env'' lns+getL :: Lens s a -> s -> a+getL l = getConstant . l Constant +over :: Lens s a -> (a -> a) -> s -> s+over l f = runIdentity . l (Identity . f)++-- * State Lenses++emptyHppState :: Config -> HppState+emptyHppState cfg = HppState cfg 1 [] emptyEnv++getL' :: (Monad m, HasHppState m) => Lens HppState a -> Parser m i a+getL' l = liftP (getL l <$> getState)++setL' :: (Monad m, HasHppState m) => Lens HppState a -> a -> m ()+setL' l x = getState >>= setState . setL l x++over' :: (Monad m, HasHppState m)+      => Lens HppState a -> (a -> a) -> Parser m i ()+over' l f = liftP $ do st <- getState+                       setState $ over l f st++-- * State Zooming++expandLineP :: (HppCaps m, Monad m) => Parser m Token [Token]+expandLineP =+  do st <- liftP getState+     let ln = hppLineNum st+         cfg = hppConfig st+     expandLine cfg ln++lookupEnv :: (Monad m, HasHppState m) => String -> Parser m i (Maybe Macro)+lookupEnv s = liftP $+              do st <- getState+                 case lookupKey s (getL env st) of+                   Nothing -> return Nothing+                   Just (m,env') -> Just m <$ setState (setL env env' st)++-- | Register a 'Cleanup' in a threaded 'HppState'.+hppRegisterCleanup :: (HasHppState m, Monad m) => Cleanup -> m ()+hppRegisterCleanup c = modifyState $ over cleanups (c:)++type InputStream m = Source m String ()++class HasHppFileIO m where+  -- | Read a file as an 'Hpp' action+  hppReadFile :: Int -> FilePath -> m (InputStream m)++  -- | Read a file available on the search path after the path+  -- containing the current file.+  hppReadNext :: Int -> FilePath -> m (InputStream m)++-- | Lets us fix 'HppT''s input type to a 'Source' whose context is+-- the type we are defining.+newtype HppStream m a = HppStream ( HppT (InputStream (HppStream m)) m a )+  deriving (Functor, Applicative, Monad, MonadIO, HasHppState, HasError, HasEnv)++instance Monad m => HasHppFileIO (HppStream m) where+  hppReadFile n file = HppStream . HppT . return . FreeF $ ReadFile n file return+  hppReadNext n file = HppStream . HppT . return . FreeF $ ReadNext n file return++incLine :: (Monad m, HasHppState m) => Parser m i ()+incLine = over' lineNum (+1)++-- * Directive Processing++-- | Handle preprocessor directives (commands prefixed with an octothorpe).+directive :: forall m. (Monad m, HppCaps m) => Parser m [Token] ()+directive = zoomParseChunks (awaitJust "directive" >>= aux) >>=+            either onParserSource (maybe (return ()) precede)+  where aux :: Token -> Parser m Token (Either (Streamer m [Token] [Token] ())+                                               (Maybe (Source m [Token] ())))+        aux (Important cmd) = case cmd of+          "pragma" -> Right Nothing <$ dropLine -- Ignored+          "define" -> fmap parseDefinition takeLine >>= \case+                        Nothing -> getL' lineNum+                                   >>= throwError . BadMacroDefinition+                        Just def -> Right Nothing <$ over' env (insertPair def)+          "undef" -> do droppingWhile (not . isImportant)+                        Important name <- awaitJust "undef"+                        dropLine+                        Right Nothing <$ over' env (deleteKey name)+          "include" -> fmap (Right . Just) $ includeAux hppReadFile+          "include_next" -> fmap (Right . Just) $ includeAux hppReadNext+          "line" -> do toks <- droppingSpaces >> fmap init expandLineP+                       case toks of+                         Important n:optFile ->+                           case readMaybe n of+                             Nothing -> getL' lineNum >>=+                                        throwError . flip BadLineArgument n+                             Just ln' -> do+                               unless (null optFile) $ do+                                 let fn = unquote . detokenize +                                        . dropWhile (not . isImportant) $ optFile+                                 over' config $ \cfg ->+                                   cfg { curFileNameF = pure fn }+                               Right Nothing <$ setL' lineNum ln'+                         _ -> getL' lineNum >>=+                              throwError . flip BadLineArgument (detokenize toks)+          "ifdef" -> do ln <- getL' lineNum+                        toks <- droppingSpaces >> takeLine+                        case takeWhile isImportant toks of+                          [Important t] ->+                            lookupEnv t >>= \case+                              Nothing -> return . Left $ dropBranchLine (ln+1)+                              Just _ -> return . Left $ takeBranch (ln+1)+                          _ -> throwError . UnknownCommand ln $+                               "ifdef "++detokenize toks+          "ifndef" -> do toks <- droppingSpaces >> takeLine+                         ln <- getL' lineNum+                         case takeWhile isImportant toks of+                           [Important t] -> lookupEnv t >>= \case+                                               Nothing -> return . Left $+                                                          takeBranch (ln+1)+                                               Just _ -> return . Left $+                                                         dropBranchLine (ln+1)+                           _ -> throwError . UnknownCommand ln $+                                "ifndef "++detokenize toks+          "else" -> Right Nothing <$ dropLine+          "if" -> ifAux+          "elif" -> ifAux+          "endif" -> Right Nothing <$ dropLine+          "error" -> do ln <- getL' lineNum+                        curFile <- liftP $ curFileName . hppConfig <$> getState+                        toks <- droppingSpaces >> takeLine+                        throwError $+                          UserError ln (detokenize toks++" ("++curFile++")")+          "warning" -> Right Nothing <$ dropLine -- warnings not yet supported+          t -> do ln <- getL' lineNum+                  toks <- takeLine+                  throwError $ UnknownCommand ln (detokenize (Important t:toks))+        aux _ = error "Impossible unimportant directive"+        includeAux readFun =+          do fileName <- init <$> expandLineP+             ln <- getL' lineNum+             let fileName' = detokenize $ trimUnimportant fileName+             src <- liftP $ readFun ln fileName'+             setL' lineNum (ln+1)+             return $ streamNewFile (unquote fileName') (src ~> prepareInput)+        ifAux :: Parser m Token (Either (Streamer m [Token] [Token] ()) b)+        ifAux = do droppingSpaces+                   toks <- takeLine+                   e <- getL' env+                   ln <- getL' lineNum+                   setL' lineNum (ln - 1) -- takeLine incremented the line count+                   ex <- liftP . parse expandLineP $+                         source (squashDefines e toks)+                   let res = evalExpr <$> parseExpr ex+                   setL' lineNum ln+                   if maybe False (/= 0) res+                     then return . Left $ takeBranch ln+                     else return . Left $ dropBranchLine ln+ -- | We want to expand macros in expressions that must be evaluated--- for condtionalals, but we want to take special care when dealing+-- 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+squashDefines env' (Important "defined" : ts) = go ts   where go (t@(Other _) : ts') = t : go ts'-        go (Important "(" : ts') = Important "(" : 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'+          case lookupKey t env' of+            Nothing -> Important "0" : squashDefines env' ts'+            Just (_,env'') -> Important "1" : squashDefines env'' ts'         go [] = []-squashDefines env (t : ts) = t : squashDefines env ts+squashDefines env' (t : ts) = t : squashDefines env' ts -getCmd :: String -> Maybe (String,[Token])-getCmd = aux . dropWhile (not . isImportant) . tokenize-  where aux (Important "#" : ts) =-            let (Important cmd:toks) = dropWhile (not . isImportant) ts-            in Just (cmd, toks)+getCmd :: [Token] -> Maybe String+getCmd = aux . dropWhile notImportant+  where aux (Important "#" : ts) = case dropWhile notImportant ts of+                                     (Important cmd:_) -> Just cmd+                                     _ -> Nothing         aux _ = Nothing --- | Feed an entire conditional block (bounded by @#if@/@#endif@) as--- the first argument to the given continuation, and the remaining--- input as the second argument.-takeConditional :: [String] -> (DList String -> [String] -> r) -> r-takeConditional lns0 k = go id lns0-  where go acc [] = k acc []-        go acc (ln:lns) =-          case getCmd ln of-            Nothing -> go (acc . (ln:)) lns-            Just (cmd,_)-              | cmd == "endif" -> k (acc . (ln:)) lns-              | cmd `elem` ["if","ifdef","ifndef"] ->-                  takeConditional lns $-                  \acc' lns' -> go (acc . (ln:) . acc') lns'-              | otherwise -> go (acc . (ln:)) lns+droppingSpaces :: Monad m => Parser m Token ()+droppingSpaces = droppingWhile notImportant +-- | Take an entire conditional expression (e.g. @#if+-- ... #endif@). All the lines of the taken branch are returned, in+-- reverse order.+takeConditional :: Monad m+                => LineNum +                -> (Int -> Streamer m [Token] [Token] r)+                -> Streamer m [Token] [Token] r+takeConditional !n0 k = go (1::Int) n0+  where go 0 !n = k n+        go nesting !n = encase $ Await aux empty+          where aux ln = case getCmd ln of+                           Just cmd+                             | cmd == "endif" ->+                               encase $ Yield ln (go (nesting-1) (n+1))+                             | cmd `elem` ["if","ifdef","ifndef"] ->+                               encase $ Yield ln (go (nesting+1) (n+1))+                           _ -> encase $ Yield ln (go nesting (n+1))+ -- | Take everything up to the end of this branch, drop all remaining--- branches (if any), and inject a @line@ update command in the--- remaining stream. The first argument is the first line of branch--- being taken. This is supplied so branches not taken can be--- discounted from the running line count.-takeBranch :: [String] -> Either Error [String]-takeBranch = go id-  where go _ [] = Left UnterminatedBranch-        go acc (ln:lns) =+-- branches (if any).+takeBranch :: Monad m => LineNum -> Streamer m [Token] [Token] ()+takeBranch = go+  where go !n = encase $ Await aux empty+          where aux ln = case getCmd ln of+                           Just cmd+                             | cmd `elem` ["if","ifdef","ifndef"] ->+                               encase $ Yield ln (takeConditional (n+1) go)+                             | cmd == "endif" -> yieldLineNum n (done ())+                             | cmd `elem` ["else","elif"] ->+                               dropAllBranches $ \numSkipped ->+                                 yieldLineNum (n+1+numSkipped) empty+                           _ -> encase $ Yield ln (go (n+1))++yieldLineNum :: Monad m => LineNum -> Streamer m i [Token] r -> Streamer m i [Token] r+yieldLineNum !ln k = encase $ Yield [Important ("#line "++show ln), Other "\n"] k++dropAllBranches :: Monad m+                => (Int -> Streamer m [Token] [Token] r)+                -> Streamer m [Token] [Token] r+dropAllBranches k = dropBranch (aux 0)+  where aux !acc Nothing !numDropped = k (acc+numDropped)+        aux !acc _ !numDropped = dropBranch (aux (acc+numDropped))++dropBranchLine :: Monad m => LineNum -> Streamer m [Token] [Token] ()+dropBranchLine !ln = dropBranch $ \el numSkipped ->+                       yieldLineNum (ln + numSkipped) (traverse_ yield 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.+dropBranch :: Monad m+           => (Maybe [Token] -> Int -> Streamer m [Token] [Token] r)+           -> Streamer m [Token] [Token] r+dropBranch k = go (1::Int) 0+  where go !nesting !n = encase . flip Await empty $ \ln ->           case getCmd ln of-            Just (cmd,_)+            Just cmd+              | cmd == "endif" -> if nesting == 1+                                  then k Nothing (n+1)+                                  else go (nesting-1) (n+1)               | cmd `elem` ["if","ifdef","ifndef"] ->-                  takeConditional lns $-                  \acc' lns' -> go (acc . (ln:) . acc') lns'-              | cmd == "endif" -> Right (acc [] ++ lns)-              | cmd `elem` ["else","elif"] ->-                case dropAllBranches lns of-                  Right lns' -> Right $ acc [] ++ lns'-                  Left err -> Left err-            _ -> go (acc . (ln:)) lns+                go (nesting+1) (n+1)+              | cmd `elem` ["else", "elif"] -> if nesting == 1+                                               then k (Just ln) (n+1)+                                               else go nesting (n+1)+            _ -> go nesting (n+1) -dropAllBranches :: [String] -> Either Error [String]-dropAllBranches = aux <=< dropBranch-  where aux :: [String] -> Either Error [String]-        aux [] = Left UnterminatedBranch-        aux (ln:lns) = case getCmd ln of-                         Just ("endif",_) -> Right lns-                         _ -> dropAllBranches lns+-- | Expands an input line producing a stream of output lines.+macroExpansion :: (HppCaps m, Monad m) => Parser m [Token] (Maybe [Token])+macroExpansion = do+  awaitP >>= \case+    Nothing -> return Nothing+    Just ln ->+      case dropWhile notImportant ln of+        [] -> incLine >> return (Just ln)+        Important "#":rst -> do replace (dropWhile notImportant rst)+                                directive+                                macroExpansion+        _ -> do replace ln+                zoomParseChunks (Just <$> expandLineP) <* incLine --- | Skip to the end of a conditional branch, returning the remaining--- input.-dropBranch :: [String] -> Either Error [String]-dropBranch = go-  where go [] = Left UnterminatedBranch-        go (l:ls) = case getCmd l of-                      Just (cmd,_)-                        -- Drop nested conditional blocks-                        | cmd `elem` ["if","ifdef","ifndef"] ->-                          dropAllBranches ls >>= go-                        | cmd `elem` ["else","elif","endif"] -> Right (l:ls)-                        | otherwise -> go ls-                      Nothing -> go ls+-- | The dynamic capabilities offered by HPP+type HppCaps t = (HasError t, HasHppState t, HasHppFileIO t, HasEnv t) --- | Returns a new macro binding environment and the result of--- expanding the input string.-macroExpansion :: Config-               -- ^ Options controlling the preprocessor-               -> Env-               -- ^ Macro binding environment-               -> [String]-               -- ^ Input lines-               -> ErrHpp (Env, [String])-macroExpansion cfg0 macros = go 1 cfg0 macros id-  where go :: Int -> Config -> [(String, Macro)]-           -> DList String -> [String]-           -> ErrHpp (Env, [String])-        go _ _ ms acc [] = return (ms, acc [])-        go lineNum cfg ms acc (x:xs) =-          case dropWhile isSpace x of-            [] -> go (lineNum + 1) cfg ms (acc . (x:)) xs-            ('#':cmd) -> do k <- directive cfg lineNum cmd-                            k (\lineNum' newLines cfg' ms' remainingInput ->-                                 go lineNum' cfg' ms' (acc . (newLines++))-                                    remainingInput)-                              ms xs-            _ -> do (ms',x') <- either errorHpp pure $-                                expandLine cfg lineNum ms (tokenize x)-                    go (lineNum+1) cfg ms' (acc . (detokenize x':)) xs+parseStreamHpp :: Monad m+               => Parser m i (Maybe o)+               -> Source m i ()+               -> Source m o ()+parseStreamHpp (Parser m) = go+  where go src = Streamer $+                 do (o,src') <- runStateT m src+                    case o of+                      Nothing -> return $ Done (Just ())+                      Just o' -> return $ Yield o' (go src') --- | @preprocess env src@ runs the pre-processor over source code--- @src@ beginning with macro binding environment @env@.-preprocess :: Env -> String -> ErrHpp (Env, String)-preprocess env inp =-  do cfg <- liftHpp $ GetConfig return-     let splicer = if spliceLongLines cfg then lineSplicing else id-         decomment = if eraseCComments cfg then commentRemoval else id-         appSplicer = if runIdentity (spliceApplicationsF cfg)-                        then spliceApplications else id-         go = macroExpansion cfg env-              -- (\lns -> return (env, lns))-            . appSplicer . splicer . decomment-            . map trigraphReplacement-     fmap (second unlines) . go $ lines inp+-- * HPP configurations --- | Run an 'Hpp' action that might fail with a given initial--- configuration.-runErrHppIO :: Config -> ErrHpp a -> IO a-runErrHppIO cfg = fmap (either err (either err id)) . runHpp cfg . runErrHpp-  where err :: (FilePath,Error) -> a-        err = error . show+-- | Standard CPP settings for processing C files.+normalCPP :: Monad m => Streamer m String [Token] ()+normalCPP = mapping trigraphReplacement+          ~> mapping dropOneLineBlockComments+          ~> removeMultilineComments 1+          ~> mapping dropLineComments+          ~> lineSplicing+          ~> mapping ((++[Other "\n"]) . tokenize)++-- | For Haskell we often want to ignore C-style comments and long+-- line splicing.+haskellCPP :: Monad m => Streamer m String [Token] ()+haskellCPP = mapping ((++[Other "\n"]) . tokenize)++-- | If we don't have a predefined processor, we build one based on a+-- 'Config' value.+genericConfig :: Monad m => Config -> Streamer m String [Token] ()+genericConfig cfg = mapping trigraphReplacement+                  ~> (if eraseCComments cfg then commentRemoval else idS)+                  ~> (if spliceLongLines cfg then lineSplicing else idS)+                  ~> mapping ((++[Other "\n"]) . tokenize)+  where idS :: Monad m => Streamer m i i r+        idS = encase $ Await (encase . flip Yield idS) empty++-- * Front End++prepareInput :: (Monad m, HppCaps m)+             => Streamer m String [Token] ()+prepareInput = Streamer $+  do cfg <- getL config <$> getState+     case () of+       _ | eraseCComments cfg && spliceLongLines cfg +           && not (inhibitLinemarkers cfg) -> runStream normalCPP+       _ | not (eraseCComments cfg || spliceLongLines cfg) ->+           runStream haskellCPP+       _ | otherwise -> runStream $ genericConfig cfg+{-# SPECIALIZE prepareInput :: Streamer (HppStream IO) String [Token] () #-}++-- | Run a stream of lines through the preprocessor.+preprocess :: (Monad m, HppCaps m)+           => Source m String ()+           -> Source m String ()+preprocess src = Streamer $+  do cfg <- getL config <$> getState+     runStream $ if inhibitLinemarkers cfg+                 then go ~> filtering (not . isPrefixOf "#line")+                 else go+  where {-# INLINE go #-}+        go = parseStreamHpp macroExpansion (src ~> prepareInput)+           ~> mapping detokenize++-- | Preprocess the given file producing line by line output.+streamHpp :: (Monad m, HasHppFileIO m)+          => FilePath -> Source m String ()+streamHpp f = Streamer $+              hppReadFile 0 ('"':f++"\"") >>= runStream++-- | Monad morphism between Hpp and IO.+hppIO :: (MonadIO m) => Config -> Env+      -> Streamer (HppStream m) Void b r+      -> Streamer (HppStream m) b Void ()+      -> m (Maybe ())+hppIO cfg env' s snk = runHpp (sourceFile hppRegisterCleanup)+                              initialState+                              (run (s ~> snk))+                       >>= either (error .show) cleanup+  where cleanup (e, s') = e <$ (liftIO $ mapM_ runCleanup (getL cleanups s'))+        initialState = setL env env' $ emptyHppState cfg

@@ -0,0 +1,100 @@+{-# LANGUAGE RankNTypes #-} +-- | 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 Hpp+import Hpp.Config+import Hpp.Env (deleteKey, emptyEnv, insertPair)+import Hpp.Tokens+import Hpp.Types (Env, Error(..))+import System.Directory (doesFileExist, makeAbsolute)++-- | Break a string on an equals sign. For example, the string @x=y@+-- is broken into @[x,"=",y]@.+breakEqs :: String -> [String]+breakEqs = aux . break (== '=')+  where aux (h,[]) = [h]+        aux (h,'=':t) = [h,"=",t]+        aux _ = error "breakEqs broke"++-- | If no space is included between a switch and its argument, break+-- it into two tokens to simplify parsing.+splitSwitches :: String -> [String]+splitSwitches ('-':'I':t@(_:_)) = ["-I",t]+splitSwitches ('-':'D':t@(_:_)) = ["-D",t]+splitSwitches ('-':'U':t@(_:_)) = ["-U",t]+splitSwitches ('-':'o':t@(_:_)) = ["-o",t]+splitSwitches x = [x]++-- FIXME: Defining function macros probably doesn't work here.+parseArgs :: ConfigF Maybe -> [String]+          -> IO (Either Error (Env, [String], Config, Maybe FilePath))+parseArgs cfg0 = go emptyEnv id cfg0 Nothing . concatMap breakEqs+  where go env acc cfg out [] =+          case realizeConfig cfg of+            Just cfg' -> return (Right (env, acc [], cfg', out))+            Nothing -> return (Left NoInputFile)+        go env acc cfg out ("-D":name:"=":body:rst) =+          case parseDefinition (Important name : Other " " : tokenize body) of+            Nothing -> return . Left $ BadMacroDefinition 0+            Just def -> go (insertPair def env) acc cfg out rst+        go env acc cfg out ("-D":name:rst) =+          case parseDefinition ([Important name, Other " ", Important "1"]) of+            Nothing -> return . Left $ BadMacroDefinition 0+            Just def -> go (insertPair def env) acc cfg out rst+        go env acc cfg out ("-U":name:rst) =+          go (deleteKey name env) acc cfg out rst+        go env acc cfg out ("-I":dir:rst) =+          let cfg' = cfg { includePathsF = fmap (++[dir]) (includePathsF cfg) }+          in go env acc cfg' out rst+        go env acc cfg out ("-include":file:rst) =+          let ln = "#include \"" ++ file ++ "\""+          in go env (acc . (ln:)) cfg out rst+        go env acc cfg out ("-P":rst) =+          let cfg' = cfg { inhibitLinemarkersF = Just True }+          in go env acc cfg' out rst+        go env acc cfg out ("--cpp":rst) =+          let cfg' = cfg { spliceLongLinesF = Just True+                         , eraseCCommentsF = Just True }+              defs = concatMap ("-D":)+                       [ ["__STDC__"]+                         -- __STDC_VERSION__ is only defined in C94 and later+                       , ["__STDC_VERSION__","=","199409L"]+                       , ["_POSIX_C_SOURCE","=","200112L"] ]+          in go env acc cfg' out (defs ++ rst)+        go env acc cfg out ("--fline-splice":rst) =+          go env acc (cfg { spliceLongLinesF = Just True }) out rst+        go env acc cfg out ("--ferase-comments":rst) =+          go env acc (cfg { eraseCCommentsF = Just True }) out rst+        go env acc cfg _ ("-o":file:rst) =+          go env acc cfg (Just file) rst+        go env acc cfg out ("-x":_lang:rst) =+          go env acc cfg out rst -- We ignore source language specification+        go env acc cfg Nothing (file:rst) =+          case curFileNameF cfg of+            Nothing -> go env acc (cfg { curFileNameF = Just file }) Nothing rst+            Just _ -> go env acc cfg (Just file) rst+        go _ _ _ (Just _) _ =+          return . Left $ BadCommandLine "Multiple output files given"++-- | Run Hpp with the given commandline arguments.+runWithArgs :: [String] -> IO ()+runWithArgs args =+  do cfgNow <- defaultConfigFNow+     let args' = concatMap splitSwitches args+     (env,lns,cfg,outPath) <- fmap (either (error . show) id)+                                   (parseArgs cfgNow args')+     exists <- doesFileExist (curFileName cfg)+     unless exists . error $+       "Couldn't open input file: "++curFileName cfg+     let fileName = curFileName cfg+         cfg' = cfg { curFileNameF = pure fileName }+     snk <- case outPath of+              Nothing -> pure sinkToStdOut+              Just f -> fmap (\f' -> sinkToFile hppRegisterCleanup f')+                             (makeAbsolute f)+     _ <- hppIO cfg' env+            (preprocess (before (source lns) (streamHpp fileName)))+            snk+     return ()

@@ -21,7 +21,7 @@                         , includePathsF       :: f [FilePath]                         , spliceLongLinesF    :: f Bool                         , eraseCCommentsF     :: f Bool-                        , spliceApplicationsF :: f Bool+                        , inhibitLinemarkersF :: f Bool                         , prepDateF           :: f DateString                         , prepTimeF           :: f TimeString } @@ -34,11 +34,11 @@                       (Just paths)                       (Just spliceLines)                       (Just comments)-                      (Just spliceApps)+                      (Just inhibitLines)                       (Just pdate)                       (Just ptime)) =   Just (Config (pure fileName) (pure paths) (pure spliceLines) (pure comments)-               (pure spliceApps) (pure pdate) (pure ptime))+               (pure inhibitLines) (pure pdate) (pure ptime)) realizeConfig _ = Nothing  -- | Extract the current file name from a configuration.@@ -56,6 +56,10 @@ -- | Determine if C-style comments should be erased. eraseCComments :: Config -> Bool eraseCComments = runIdentity . eraseCCommentsF++-- | Determine if generation of linemarkers should be inhibited.+inhibitLinemarkers :: Config -> Bool+inhibitLinemarkers = runIdentity . inhibitLinemarkersF  -- | The date the pre-processor was run on. prepDate :: Config -> DateString

@@ -1,15 +1,42 @@ -- | A name binding context, or environment. module Hpp.Env where-import Hpp.Types (Macro) --- | A macro binding environment.-type Env = [(String, Macro)]+{-+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 #-}++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 #-}++-- | Add a @(key,value)@ pair to an environment.+insertPair :: a -> [a] -> [a]+insertPair = (:)+{-# INLINE insertPair #-}+ -- | 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 #-}  -- | 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@@ -20,3 +47,4 @@         go acc (h@(x,v) : xs)           | k == x = Just (v, h : acc [] ++ xs)           | otherwise = go (acc . (h:)) xs+{-# INLINE lookupKey #-}

@@ -1,17 +1,22 @@+{-# LANGUAGE RankNTypes, ScopedTypeVariables #-} -- | 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-import Control.Arrow (first)-import Control.Monad ((<=<))+import Control.Monad (forM) import Data.Bool (bool)+import Data.Foldable (foldl', traverse_) import Data.List (delete) import Data.Maybe (listToMaybe, mapMaybe)-import Hpp.Config-import Hpp.Env-import Hpp.String-import Hpp.Tokens-import Hpp.Types+import Hpp.Config (Config, curFileName,+                   getDateString, getTimeString, prepDate, prepTime)+import Hpp.Env (lookupKey, deleteKey)+import Hpp.Streamer (source, mapTil)+import Hpp.Parser (Parser, awaitP, liftP, precede, zoomParse,+                   droppingWhile, awaitJust, replace, parse)+import Hpp.String (stringify)+import Hpp.Tokens (Token(..), notImportant, isImportant, detokenize)+import Hpp.Types (HasError(..), HasEnv(..), Scan(..), Error(..), Macro(..))  -- | Extract the 'Token' payload from a 'Scan'. unscan :: Scan -> Maybe Token@@ -19,159 +24,170 @@ unscan (Rescan t) = Just t unscan _ = Nothing --- | Expand a single line of tokenized code.-expandLine :: Config -> Int -> Env -> [Token]-           -> Either Error (Env, [Token])-expandLine cfg lineNum macros = fmap (\(e,ts) -> (e, mapMaybe unscan ts))-                              . expandLine' cfg lineNum macros . map Scan+isSpaceScan :: Scan -> Bool+isSpaceScan = maybe False notImportant . unscan +isImportantScan :: Scan -> Bool+isImportantScan = maybe False isImportant . unscan++-- | Expand all macros to the end of the current line or until all+-- in-progress macro invocations are complete, whichever comes last.+expandLine :: (HasError m, Monad m, HasEnv m)+           => Config -> Int -> Parser m Token [Token]+expandLine cfg lineNum = fmap (mapMaybe unscan) $+                         zoomParse (mapTil Scan)+                                   (expandLine' True cfg lineNum)++expandLine' :: forall m. (HasError m, Monad m, HasEnv m)+            => Bool -> Config -> Int -> Parser m Scan [Scan]+expandLine' oneLine cfg lineNum = go id []+  where go :: ([Scan] -> [Scan]) -> [String] -> Parser m Scan [Scan]+        go acc mask = awaitP >>= maybe (return $ acc []) aux+          where aux :: Scan -> Parser m Scan [Scan]+                aux tok = case tok of+                  Unmask name -> go (acc . (tok:)) (delete name mask)+                  Mask name -> go (acc . (tok:)) (name : mask)+                  Scan (Important t) -> do ts <- expandMacro cfg lineNum t tok+                                           if ts == [tok]+                                           then go (acc . (tok:)) mask+                                           else do precede $ source ts+                                                   go acc mask+                  Rescan (Important t) ->+                    do oldEnv <- liftP $+                                 do env <- getEnv+                                    setEnv $ foldl' (flip deleteKey) env mask+                                    return env+                       ts <- expandMacro cfg lineNum t tok+                       liftP $ setEnv oldEnv+                       if ts == [tok]+                       then go (acc . (tok:)) mask+                       else precede (source ts) >> go acc mask+                  Scan (Other "\n")+                    | oneLine -> return (acc [tok])+                    | otherwise -> go (acc . (tok:)) mask+                  Rescan (Other "\n")+                    | oneLine -> return (acc [tok])+                    | otherwise -> go (acc . (tok:)) mask+                  _ -> go (acc . (tok:)) mask++-- | Parse a function application. Arguments are separated by commas,+-- and the application runs until the balanced closing parenthesis. If+-- this is not an application, 'Nothing' is returned.+appParse :: (Monad m, HasError m) => Parser m Scan (Maybe [[Scan]])+appParse = droppingWhile isSpaceScan >> checkApp+  where imp = maybe True notImportant . unscan+        checkApp = do tok <- droppingWhile imp >> awaitP+                      case tok >>= unscan of+                        Just (Important "(") -> goApp+                        _ -> traverse_ replace tok >> return Nothing+        getArg acc = do arg <- fmap trimScan argParse+                        tok <- awaitJust "appParse getArg"+                        case unscan tok of+                          Just (Important ")") -> return (acc [arg])+                          _ -> replace tok >> getArg (acc . (arg:))+        goApp = fmap Just (getArg id)++-- | Emit the tokens of a single argument. Returns 'True' if this is+-- the final argument in an application (indicated by an unbalanced+-- closing parenthesis.+argParse :: (Monad m, HasError m) => Parser m Scan [Scan]+argParse = go id+  where go acc = do tok <- awaitJust "argParse"+                    case unscan tok of+                      Just (Important s)+                        | s == ")" -> replace tok >> return (acc [])+                        | s == "," -> return (acc [])+                        | s == "(" -> do ts <- fmap (tok:) parenthetical+                                         go (acc . (ts++))+                        | otherwise -> go (acc . (tok:))+                      _ -> go (acc . (tok:))++-- | Kick this off after an opening parenthesis and it will yield+-- every token up to the closing parenthesis.+parenthetical :: (Monad m, HasError m) => Parser m Scan [Scan]+parenthetical = go id (1::Int)+  where go acc 0 = return (acc [])+        go acc n = do tok <- awaitJust "parenthetical"+                      case unscan tok of+                        Just (Important "(") -> go (acc . (tok:)) (n+1)+                        Just (Important ")") -> go (acc . (tok:)) (n-1)+                        _ -> go (acc . (tok:)) n+ argError :: Int -> String -> Int -> [String] -> Error argError lineNum name arity args =   TooFewArgumentsToMacro lineNum $ name++"<"++show arity++">"++show args --- | Returns the /used/ environment and the new token stream.-expandFunction :: String -> Int -> ([([Scan],String)] -> [Scan])-               -> ([String] -> Error)-               -> ([Scan] -> Either Error [Scan])-               -> [Scan]-               -> Maybe (Either Error [Scan])-expandFunction name arity f mkErr expand = aux <=< argParse-  where aux :: ([[Scan]],[Scan]) -> Maybe (Either Error [Scan])-        aux (args,rst)-          | length args /= arity = Just . Left . mkErr-                                 $ map (detokenize . mapMaybe unscan) args-          | otherwise = Just $-                        do args' <- mapM expand args-                           let raw = map (detokenize . mapMaybe unscan) args-                           return $ Mask name : f (zip args' raw) ++-                                    Unmask name : rst+-- | Returns 'Nothing' if this isn't an application; @Left args@ if we+-- parsed arguments @args@, but there is an arity mismatch; or @Right+-- tokens@ if the function application expanded successfully.+expandFunction :: (Monad m, HasError m)+               => String -> Int -> ([([Scan],String)] -> [Scan])+               -> (forall r'. [String] -> Parser m Scan r')+               -> Parser m Scan [Scan]+               -> Parser m Scan (Maybe [Scan])+expandFunction name arity f mkErr expand =+  do margs <- appParse+     case margs of+       Nothing -> return Nothing+       Just args+         | length args /= arity -> mkErr $+                                   map (detokenize . mapMaybe unscan) args+         | otherwise ->+           do args' <- forM args $ \arg -> liftP (parse expand (source arg))+              let raw = map (detokenize . mapMaybe unscan) args+              return . Just $ Mask name : f (zip args' raw) ++ [Unmask name] -type EnvLookup = String -> Maybe (Macro, Env)+lookupEnv :: (Monad m, HasEnv m)+          => String -> Parser m i (Maybe Macro)+lookupEnv s = liftP $ getEnv >>= traverse aux . lookupKey s+  where aux (m, env') = setEnv env' >> return m -expandMacro :: Config -> Int -> EnvLookup -> String -> Scan -> [Scan]-            -> (DList Scan -> Maybe Env -> [Scan] -> Either Error r)-            -> Either Error r-expandMacro cfg lineNum env name tok ts k =+expandMacro :: (Monad m, HasError m, HasEnv m)+            => Config -> Int -> String -> Scan -> Parser m Scan [Scan]+expandMacro cfg lineNum name tok =   case name of     "__LINE__" -> simple $ show lineNum     "__FILE__" -> simple . stringify $ curFileName cfg     "__DATE__" -> simple . stringify . getDateString $ prepDate cfg     "__TIME__" -> simple . stringify . getTimeString $ prepTime cfg-    _ -> case env name of-           Nothing -> k (tok:) Nothing ts-           Just (m,env') ->-             case m of-               Object t' ->-                 let expansion = Mask name-                               : map Rescan (spaced t')-                               ++ [Unmask name]-                 in k id (Just env') (expansion++ts)-               Function arity f ->-                 let ex = fmap snd-                        . expandLine' cfg lineNum (deleteKey name env')-                     err = argError lineNum name arity-                 in case expandFunction name arity f err ex ts of-                      Nothing -> k (tok:) (Just env') ts-                      -- FIXME: Missing call to spaced?-                      Just ts' ->-                        do tsEx <- ts'-                           k id (Just env') tsEx-  where simple s = k (Rescan (Important s):) Nothing ts+    _ -> do mm <- lookupEnv name+            case mm of+              Nothing -> return [tok]+              Just m ->+                case m of+                  Object t' ->+                    return $ Mask name : map Rescan (spaced t') ++ [Unmask name]+                  Function arity f ->+                    let ex = expandLine' False cfg lineNum+                        err = liftP . throwError+                            . argError lineNum name arity+                    in do mts <- expandFunction name arity f err ex+                          case mts of+                            Nothing -> return [tok]+                            Just ts -> return ts+  where simple s = return [Rescan (Important s)]         -- Avoid accidentally merging tokens like @'-'@-        spaced xs = pre xs ++ pos+        spaced xs = pre ++ pos           where importantChar (Important [c]) = elem c oops                 importantChar _ = False-                pre = bool id (Other " ":)$+                pre = bool xs (Other " ":xs)$                       (maybe False importantChar $ listToMaybe xs)                 pos = bool [] [Other " "] $                       (maybe False importantChar $ listToMaybe (reverse xs))                 oops = "-+*.><" -withMask :: Eq a => [a] -> (a -> Maybe b) -> a -> Maybe b-withMask mask f = \x -> if elem x mask then Nothing else f x---- | Expand all macros on a /non-directive/ line. If there is a problem--- expanding a macro (this will typically be a macro function), the--- name of the name of the problematic macro is returned.-expandLine' :: Config -> Int -> Env -> [Scan]-           -> Either Error (Env, [Scan])-expandLine' cfg lineNum macros = go macros id []-  where go :: Env -> DList Scan -> [String] -> [Scan]-           -> Either Error (Env, [Scan])-        go env acc _ [] = Right (env, acc [])-        go env acc mask (tok@(Unmask name) : ts) =-          go env (acc . (tok:)) (delete name mask) ts-        go env acc mask (tok@(Mask name) : ts) =-          go env (acc . (tok:)) (name:mask) ts-        go env acc mask (tok@(Rescan (Important t)) : ts) =-          let envMasked = withMask mask (flip lookupKey env)-          in expandMacro cfg lineNum envMasked t tok ts $ \fAcc _ ts' ->-             go env (acc . fAcc) mask  ts'-        go env acc mask (tok@(Scan (Important t)) : ts) =-          let envLook = flip lookupKey env-          in expandMacro cfg lineNum envLook t tok ts $ \fAcc env' ts' ->-             go (maybe env id env') (acc . fAcc) mask ts'-        go env acc mask (t:ts) = go env (acc . (t:)) mask ts---- | @breakBalance end tokens@ uses the first element of @tokens@ as--- the start of a balanced pair, and @end@ as the end of such a--- pair. It breaks @tokens@ into a prefix with as many @end@ as start--- tokens, and the remaining tokens.-breakBalance :: (a -> Bool) -> (a -> Bool) -> [a] -> Maybe ([a],[a])-breakBalance _ _ [] = Nothing-breakBalance start end ts0 = go (1::Int) id ts0-  where go 0 acc ts = Just (acc [], ts)-        go _ _ [] = Nothing-        go n acc (t:ts)-          | end t = go (n-1) (acc . (t:)) ts-          | start t = go (n+1) (acc . (t:)) ts-          | otherwise = go n (acc . (t:)) ts- -- | Trim whitespace from both ends of a sequence of 'Scan' tokens. trimScan :: [Scan] -> [Scan] trimScan [] = []-trimScan (Scan (Other _):ts) = trimScan ts-trimScan (Rescan (Other _):ts) = trimScan ts-trimScan (t@(Rescan (Important _)) : ts) = t : trimScanAux Nothing ts-trimScan (t@(Scan (Important _)) : ts) = t : trimScanAux Nothing ts-trimScan (t@(Mask _) : ts) = t : trimScan ts-trimScan (t@(Unmask _) : ts) = t : trimScan ts+trimScan (t:ts) | isSpaceScan t = trimScan ts+                | isImportantScan t = t : trimScanAux Nothing ts+                | otherwise = t : trimScan ts  -- | Collapse internal whitespace to single spaces, and trim trailing -- space. trimScanAux :: Maybe Scan -> [Scan] -> [Scan] trimScanAux _ [] = []-trimScanAux _ (Scan (Other _) : ts) = trimScanAux (Just (Scan (Other " "))) ts-trimScanAux _ (Rescan (Other _) : ts) = trimScanAux (Just (Scan (Other " "))) ts-trimScanAux spc (t@(Mask _) : ts) = t : trimScanAux spc ts-trimScanAux spc (t@(Unmask _) : ts) = t : trimScanAux spc ts-trimScanAux spc (t:ts) = maybe [] (:[]) spc ++  (t : trimScanAux Nothing ts)---- | Parse a function application. Arguments are separated by commas,--- and the application runs until a closing parenthesis. The input--- stream should begin immediately /after/ the opening parenthesis.-argParse :: [Scan] -> Maybe ([[Scan]], [Scan])-argParse = fmap (first (map trimScan))-         . go id id-       <=< isApplication-         . dropWhile (maybe True not . fmap isImportant . unscan)-  where go accArgs accArg (t@(Scan (Important s)):ts) =-          aux accArgs accArg t ts s-        go accArgs accArg (t@(Rescan (Important s)):ts) =-          aux accArgs accArg t ts s-        go accArgs accArg (t : ts) = go accArgs (accArg . (t:)) ts-        go _ _ [] = Nothing-        aux accArgs accArg t ts s =-          case s of -            ")" -> Just (accArgs [accArg []], ts)-            "," -> go (accArgs . (accArg [] :)) id ts-            "(" -> case breakBalance (isTok "(") (isTok ")") ts of-                     Nothing -> Nothing-                     Just (arg,ts') -> go accArgs (accArg . (t:) . (arg++)) ts'-            _ -> go accArgs (accArg . (t:)) ts-        isApplication (Scan (Important "("):ts) = Just ts-        isApplication (Rescan (Important "("):ts) = Just ts-        isApplication _ = Nothing-        isTok t (Scan (Important s)) = t == s-        isTok t (Rescan (Important s)) = t == s-        isTok _ _ = False+trimScanAux spc (t : ts)+  | isSpaceScan t = trimScanAux (Just (Scan (Other " "))) ts+  | isImportantScan t = maybe [] (:[]) spc ++ (t : trimScanAux Nothing ts)+  | otherwise = t : trimScanAux spc ts

@@ -1,3 +1,4 @@+{-# LANGUAGE ConstraintKinds, RankNTypes, ScopedTypeVariables #-} -- | An expression language corresponding to the subset of C syntax -- that may be used in preprocessor conditional directives. See -- <https://gcc.gnu.org/onlinedocs/cpp/If.html>@@ -9,6 +10,9 @@ import Text.Read (readMaybe) import Hpp.Tokens import Data.Char (digitToInt, toLower)+import Data.Proxy (Proxy(..))+import Data.Bifunctor (bimap)+import Data.Bits (Bits)  -- * Token Parsing Types @@ -21,11 +25,72 @@  data UnaryOp = Neg | BitNot | Not | Defined deriving (Eq,Ord,Show) -data Lit = LitInt Int | LitStr String | LitChar Char | LitID String+data Lit = LitInt Int | LitUInt Word | LitStr String | LitChar Char | LitID String            deriving (Eq,Ord,Show)  data Parsed = PBinOp BinOp | PUnaryOp UnaryOp | PLit Lit deriving (Eq,Ord,Show) +-- * Integers++-- | If one side of an operator is unsigned, the other side is converted+-- to unsigned.+newtype CppInt = CppInt { getCppInt :: Either Word Int }++onCommonType :: forall p c. (c Word, c Int)+             => p c+             -> (forall a. c a => a -> a -> a)+             -> CppInt -> CppInt -> CppInt+onCommonType _ f (CppInt (Right x)) (CppInt (Right y)) = CppInt (Right (f x y))+onCommonType _ f (CppInt (Left x)) (CppInt (Left y)) = CppInt (Left (f x y))+onCommonType _ f (CppInt (Right x)) (CppInt (Left y)) =+  CppInt (Left $ f (fromIntegral x) y)+onCommonType _ f (CppInt (Left x)) (CppInt (Right y)) =+  CppInt (Left $ f x (fromIntegral y))++instance Eq CppInt where+  CppInt (Left x) == CppInt (Right y) = x == fromIntegral y+  CppInt (Right x) == CppInt (Left y) = fromIntegral x == y+  CppInt x == CppInt y = x == y++onCommonTypeB :: forall p c. (c Word, c Int)+              => p c+              -> (forall a. c a => a -> a -> Bool)+              -> CppInt -> CppInt -> Bool+onCommonTypeB _ f (CppInt (Right x)) (CppInt (Right y)) = f x y+onCommonTypeB _ f (CppInt (Left x)) (CppInt (Left y)) = f x y+onCommonTypeB _ f (CppInt (Right x)) (CppInt (Left y)) = f (fromIntegral x) y+onCommonTypeB _ f (CppInt (Left x)) (CppInt (Right y)) = f x (fromIntegral y)++instance Ord CppInt where+  x < y = onCommonTypeB (Proxy::Proxy Ord) (<) x y+  x > y = onCommonTypeB (Proxy::Proxy Ord) (>) x y+  x <= y = onCommonTypeB (Proxy::Proxy Ord) (<=) x y+  x >= y = onCommonTypeB (Proxy::Proxy Ord) (>=) x y+  max x y = onCommonType (Proxy::Proxy Ord) max x y+  min x y = onCommonType (Proxy::Proxy Ord) min x y++instance Num CppInt where+  x + y = onCommonType (Proxy::Proxy Num) (+) x y+  x - y = onCommonType (Proxy::Proxy Num) (-) x y+  x * y = onCommonType (Proxy::Proxy Num) (*) x y+  negate (CppInt x) = CppInt (Right $ either (negate . fromIntegral) negate x)+  abs (CppInt x) = CppInt (bimap abs abs x)+  signum (CppInt x) = CppInt (bimap signum signum x)+  fromInteger = CppInt . Right . fromInteger++integralCpp :: (forall a. Integral a => a -> a -> a) -> CppInt -> CppInt -> CppInt+integralCpp = onCommonType (Proxy::Proxy Integral)++bitsCpp :: (forall a. Bits a => a -> a -> a) -> CppInt -> CppInt -> CppInt+bitsCpp = onCommonType (Proxy::Proxy Bits)++cppShiftL,cppShiftR :: CppInt -> Int -> CppInt+cppShiftL (CppInt x) s = CppInt $ bimap (`shiftL` s) (`shiftL` s) x+cppShiftR (CppInt x) s = CppInt $ bimap (`shiftR` s) (`shiftR` s) x++cppComplement :: CppInt -> CppInt+cppComplement (CppInt x) = CppInt $ bimap complement complement x+ -- * Associativity and Precedence  data Assoc = RightLeft | LeftRight deriving (Eq, Ord, Show)@@ -182,20 +247,21 @@  parseLit :: String -> Maybe Lit parseLit s = case readLitInt s of-               Just i -> Just (LitInt i)+               Just (CppInt i) -> Just (either LitUInt LitInt i)                Nothing -> case readNarrowChar s <|> readWideChar s  of                             Just c -> Just (LitChar c)                             Nothing -> case readMaybe s of                                          Just str -> Just (LitStr str)                                          Nothing -> Nothing -digitsFromBase :: Int -> [Int] -> Int+digitsFromBase :: Word -> [Word] -> Word digitsFromBase base = foldl' aux 0   where aux acc d = base*acc + d -readLitInt' :: String -> Maybe Int+readLitInt' :: String -> Maybe Word readLitInt' ('0':x:hexDigits)-  | x == 'x' || x == 'X' = fmap (digitsFromBase 16) (mapM hexDigit hexDigits)+  | x == 'x' || x == 'X' = fmap (digitsFromBase 16)+                                (mapM (fmap fromIntegral . hexDigit) hexDigits)   where hexDigit c           | c >= '0' && c <= '9' = Just $ digitToInt c           | c >= 'a' && c <= 'f' = Just $ (fromEnum c - fromEnum 'a') + 10@@ -205,19 +271,20 @@ readLitInt' ('0':octalDigits) = fmap (digitsFromBase 8)                                      (mapM octalDigit octalDigits)   where octalDigit c-          | c >= '0' && c < '8' = Just $ digitToInt c+          | c >= '0' && c < '8' = Just . fromIntegral $ digitToInt c           | otherwise = Nothing readLitInt' s = readMaybe s  -- | Read a literal integer. These may be decimal, octal, or -- hexadecimal, and may have a case-insensitive suffix of @u@, @l@, or -- @ul@.-readLitInt :: String -> Maybe Int+readLitInt :: String -> Maybe CppInt readLitInt s = case map toLower . take 2 $ reverse s of-                 "lu" -> readLitInt' (init (init s))+                 "lu" -> fmap (CppInt . Left) (readLitInt' (init (init s)))                  'l':_ -> readLitInt (init s)-                 'u':_ -> readLitInt (init s)-                 _ -> readLitInt' s+                 'u':_ -> fmap (CppInt . Left . asWord) (readLitInt (init s))+                 _ -> fmap (CppInt . Right . fromIntegral) (readLitInt' s)+  where asWord = either id fromIntegral . getCppInt  -- * Shunting Yard @@ -307,6 +374,7 @@ -- C syntax (some parentheses may be added). renderExpr :: Expr -> String renderExpr (ELit (LitInt e)) = show e+renderExpr (ELit (LitUInt e)) = show e ++ "U" renderExpr (ELit (LitStr e)) = '"':e++"\"" renderExpr (ELit (LitChar c)) = [c] renderExpr (ELit (LitID e)) = e@@ -316,36 +384,44 @@  -- * Evaluation +-- | All 'Expr's can be evaluated to an 'Int'.+evalExpr :: Expr -> Int+evalExpr = either fromIntegral id . getCppInt . evalExpr'+ -- | @evalExpr isDefined e@ evaluates expression @e@ in an environment -- where the existence of macro definitions is captured by the -- @isDefined@ predicate. All expressions evaluate to an 'Int'!-evalExpr :: Expr -> Int-evalExpr = go-  where go (ELit (LitInt e)) = e-        go (ELit (LitStr _)) = 1-        go (ELit (LitID _)) = 0-        go (ELit (LitChar c)) = fromEnum c+evalExpr' :: Expr -> CppInt+evalExpr' = go+  where int = CppInt . Right+        word = CppInt . Left+        asInt = either fromIntegral id . getCppInt+        go (ELit (LitInt e)) = int e+        go (ELit (LitUInt e)) = word e+        go (ELit (LitStr _)) = int 1+        go (ELit (LitID _)) = int 0+        go (ELit (LitChar c)) = int $ fromEnum c         go (EBinOp Add e2 e3) = go e2 + go e3         go (EBinOp Sub e2 e3) = go e2 - go e3         go (EBinOp Mul e2 e3) = go e2 * go e3-        go (EBinOp Div e2 e3) = go e2 `div` go e3-        go (EBinOp Mod e2 e3) = go e2 `mod` go e3-        go (EBinOp BitAnd e2 e3) = go e2 .&. go e3-        go (EBinOp BitOr e2 e3) = go e2 .|. go e3-        go (EBinOp BitXor e2 e3) = go e2 `xor` go e3-        go (EBinOp ShiftL e2 e3) = go e2 `shiftL` go e3-        go (EBinOp ShiftR e2 e3) = go e2 `shiftR` go e3-        go (EBinOp LessThan e2 e3) = fromEnum $ go e2 < go e3-        go (EBinOp GreaterThan e2 e3) = fromEnum $ go e2 > go e3-        go (EBinOp EqualTo e2 e3) = fromEnum $ go e2 == go e3-        go (EBinOp NotEqualTo e2 e3) = fromEnum $ go e2 /= go e3-        go (EBinOp GreaterOrEqualTo e2 e3) = fromEnum $ go e2 >= go e3-        go (EBinOp LessOrEqualTo e2 e3) = fromEnum $ go e2 <= go e3-        go (EBinOp And e2 e3) = fromEnum $ go e2 /= 0 && go e3 /= 0-        go (EBinOp Or e2 e3) = fromEnum $ go e2 /= 0 || go e3 /= 0-        go (EUnaryOp Neg e2) = -(go e2)-        go (EUnaryOp BitNot e2) = complement $ go e2-        go (EUnaryOp Not e2) = fromEnum $ go e2 == 0+        go (EBinOp Div e2 e3) = integralCpp div (go e2) (go e3)+        go (EBinOp Mod e2 e3) = integralCpp mod (go e2) (go e3)+        go (EBinOp BitAnd e2 e3) = bitsCpp (.&.) (go e2) (go e3)+        go (EBinOp BitOr e2 e3) = bitsCpp (.|.) (go e2) (go e3)+        go (EBinOp BitXor e2 e3) = bitsCpp xor (go e2) (go e3)+        go (EBinOp ShiftL e2 e3) = go e2 `cppShiftL` asInt (go e3)+        go (EBinOp ShiftR e2 e3) = go e2 `cppShiftR` asInt (go e3)+        go (EBinOp LessThan e2 e3) = int . fromEnum $ go e2 < go e3+        go (EBinOp GreaterThan e2 e3) = int . fromEnum $ go e2 > go e3+        go (EBinOp EqualTo e2 e3) = int . fromEnum $ go e2 == go e3+        go (EBinOp NotEqualTo e2 e3) = int . fromEnum $ go e2 /= go e3+        go (EBinOp GreaterOrEqualTo e2 e3) = int . fromEnum $ go e2 >= go e3+        go (EBinOp LessOrEqualTo e2 e3) = int . fromEnum $ go e2 <= go e3+        go (EBinOp And e2 e3) = int . fromEnum $ go e2 /= 0 && go e3 /= 0+        go (EBinOp Or e2 e3) = int . fromEnum $ go e2 /= 0 || go e3 /= 0+        go (EUnaryOp Neg e2) = negate (go e2)+        go (EUnaryOp BitNot e2) = cppComplement $ go e2+        go (EUnaryOp Not e2) = int . fromEnum $ go e2 == 0         go (EUnaryOp Defined e2) =           case e2 of              ELit (LitInt 1) -> 1

@@ -0,0 +1,153 @@+{-# LANGUAGE BangPatterns, LambdaCase, RankNTypes #-}+-- | Parsers over streaming input.+module Hpp.Parser (Parser(..), parse,+                   awaitP, awaitJust, replace, droppingWhile, liftP,+                   onParserSource, precede, takingWhile,+                   zoomParse, zoomParseChunks) where+import Control.Applicative (Alternative(..))+import Control.Monad (MonadPlus(..))+import Control.Monad.Trans.State.Strict+import Hpp.Streamer (Source, Streamer(..), yield, before, processPrefix,+                     nextOutput, flattenTil, StreamStep(..))+import Hpp.Types (HasError(..), HasHppState(..), Error(UserError))+import Control.Monad.Trans.Class (lift)+import Control.Monad.IO.Class (MonadIO, liftIO)++-- * Parsers++type ParserR m r i = StateT (Source m i r) m++-- | A 'Parser' is a 'Streamer' whose monadic context is a bit of+-- state carrying a source input stream.+newtype Parser m i o = Parser { runParser :: forall r. ParserR m r i o }++-- | Run a 'Parser' with a given input stream.+parse :: Monad m => Parser m i o -> Source m i r -> m o+parse (Parser m) s = evalStateT m s+{-# INLINE parse #-}++instance Functor m => Functor (Parser m i) where+  fmap f (Parser p) = Parser (fmap f p)+  {-# INLINE fmap #-}++instance Monad m => Applicative (Parser m i) where+  pure x = Parser (pure x)+  {-# INLINE pure #-}+  Parser f <*> Parser x = Parser (f <*> x)+  {-# INLINE (<*>) #-}++instance Monad m => Monad (Parser m i) where+  return = pure+  {-# INLINE return #-}+  Parser ma >>= fb = Parser $ ma >>= runParser . fb+  {-# INLINE (>>=) #-}++instance MonadPlus m => Alternative (Parser m i) where+  empty = Parser empty+  {-# INLINE empty #-}+  Parser a <|> Parser b = Parser (a <|> b)+  {-# INLINE (<|>) #-}++instance (Monad m, HasError m) => HasError (Parser m i) where+  throwError = liftP . throwError+  {-# INLINE throwError #-}++instance (Monad m, HasHppState m) => HasHppState (Parser m i) where+  getState = liftP getState+  setState = liftP . setState++instance MonadIO m => MonadIO (Parser m i) where+  liftIO = liftP . liftIO++-- * Operations on Parsers          ++-- | Lift a monadic action into a Parser.+liftP :: Monad m => m o -> Parser m i o+liftP m = Parser (lift m)+{-# INLINE liftP #-}++-- | @onParserSource proc@ feeds the 'Parser' source through @proc@+-- using 'processPrefix'. This means that when @proc@ finishes, the+-- remaining source continues unmodified.+onParserSource :: Monad m => Streamer m i i () -> Parser m i ()+onParserSource s = Parser (modify' (flip processPrefix s))+-- onParserSource s = Parser (get >>= lift . flip processPrefix s >>= put)+{-# INLINE onParserSource #-}++-- | Waits for a value from upstream. Returns 'Nothing' if upstream is+-- empty.+awaitP :: Monad m => Parser m i (Maybe i)+awaitP = Parser $ get >>= lift . nextOutput >>= \case+  Left _ -> put empty >> return Nothing+  Right !(!i, !src') -> put src' >> return (Just i)+{-# INLINABLE awaitP #-}++-- | 'awaitP' 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 -> Parser m i i+awaitJust s = awaitP >>= maybe (liftP $ throwError err) return+  where err = UserError 0 ("awaitJust: " ++ s)++-- | Push a value back into a parser's source.+replace :: Monad m => i -> Parser m i ()+replace x = Parser $ modify' (before (yield x))+{-# INLINE replace #-}++-- | Push a stream of values back into a parser's source.+precede :: Monad m => Source m i r -> Parser m i ()+precede m = Parser (modify' (before m))+{-# INLINE precede #-}++-- | Discard all values until one fails to satisfy a predicate. At+-- that point, the failing value is 'replace'd, and the+-- 'droppingWhile' stream stops.+droppingWhile :: Monad m => (i -> Bool) -> Parser m i ()+droppingWhile p = go+  where go = awaitP >>= \case+               Nothing -> return ()+               Just x -> if p x then go else replace x+{-# INLINE droppingWhile #-}++-- | Echo all values until one fails to satisfy a predicate. At that+-- point, the failing value is 'replace'd, and the 'takingWhile'+-- stream stops.+takingWhile :: Monad m => (i -> Bool) -> Parser m i [i]+takingWhile p = go id+  where go acc = awaitP >>= \case+                   Nothing -> return (acc [])+                   Just x+                     | p x -> go (acc . (x:))+                     | otherwise -> replace x >> return (acc [])+{-# INLINE takingWhile #-}++-- * Zooming++-- | This is rather like a Lens zoom, but quite fragile. The idea is+-- that we run a 'Parser' on a transformation of the original+-- source. The transformation of the source is responsible for+-- yielding transformed values, and ending /on demand/ with the rest+-- of the original source. We additionally scoop up any leftover+-- transformed values and prepend them onto the remaining source after+-- inverting the original transformation.+zoomParse :: Monad m+          => (forall r. Source m a r -> Source m b (Source m a r))+          -> Parser m b o+          -> Parser m a o+zoomParse f (Parser p) = Parser $ do+  src <- get+  (r, src') <- lift $ runStateT p (f src)+  lift (runStream src') >>= \case+    Await k _ -> lift (runStream (k undefined)) >>= \case+                   Done (Just src'') -> r <$ put src''+                   _ -> error "zoomParse blew it"+    Done (Just src'') -> r <$ put src''+    Done Nothing -> r <$ put empty+    Yield _ _ -> error "zoomParse blew it by yielding"+{-# INLINABLE zoomParse #-}++-- | Turn a 'Parser' on individual values into a 'Parser' on chunks.+zoomParseChunks :: Monad m => Parser m i r -> Parser m [i] r+zoomParseChunks = zoomParse flattenTil+{-# INLINE zoomParseChunks #-}+

@@ -0,0 +1,70 @@+{-# LANGUAGE LambdaCase #-}+-- | IO on streams.+module Hpp.StreamIO where+import Control.Monad.IO.Class (MonadIO, liftIO)+import Hpp.Streamer+import Hpp.Types+import System.Directory (getTemporaryDirectory, renameFile, removeFile)+import System.IO (IOMode(ReadMode), hClose, hPutStr, openTempFile, openFile,+                  hGetLine, hIsEOF, hIsClosed, hSetBuffering, BufferMode(..))++-- | @sourceFile registerCleanup filePath@ produces a 'Source' of+-- lines from file @filePath@ after registering an action that closes+-- the file using the provided @registerCleanup@ function.+sourceFile :: (MonadIO m, MonadIO m')+           => (Cleanup -> m' ()) -> FilePath -> m' (Source m String ())+sourceFile register fp =+  do h <- liftIO $ do h <- openFile fp ReadMode+                      hSetBuffering h (BlockBuffering Nothing)+                      return h+     (cleanup,neutralize) <- liftIO $ mkCleanup (hClose h)+     let {-# INLINABLE go #-}+         go :: MonadIO m => Source m String ()+         go = Streamer $+              do closed <- liftIO $ hIsClosed h+                 if closed+                 then return $ Done (Just ())+                 else do eof <- liftIO $ hIsEOF h+                         if eof+                         then Done (Just ()) <$ (liftIO (neutralize >> hClose h))+                         else liftIO (fmap (flip Yield go) (hGetLine h))+                         -- else liftIO (hGetLine h) >>= return . flip Yield go -- . (++"\n")+     register cleanup >> return go+{-# INLINE sourceFile #-}++-- | Incrementally writes 'String's to a temporary file. When all+-- input is exhausted, the temporary file is renamed to the supplied+-- 'FilePath'.+sinkToFile :: MonadIO m+           => (Cleanup -> m ()) -> FilePath -> Streamer m String o ()+sinkToFile register fp = Streamer$+  do (tmp,h) <- liftIO $ getTemporaryDirectory >>= flip openTempFile "hpp.tmp"+     (cleanup, neutralize) <- liftIO $ mkCleanup (hClose h >> removeFile tmp)+     let dunzo = Streamer . liftIO $ do neutralize+                                        hClose h+                                        renameFile tmp fp+                                        return (Done (Just ()))+         go = encase $ Await (\s -> Streamer $+                                    liftIO (hPutStr h s) >> runStream go)+                             dunzo+                             +     register cleanup+     runStream go+{-# INLINE sinkToFile #-}++-- | Sink a stream with a function evaluated only for its+-- side-effects.+sinkTell :: Monad m => (a -> m ()) -> Streamer m a o ()+sinkTell tell = go+  where go = awaits (\i -> Streamer (tell i >> runStream go))+{-# INLINE sinkTell #-}++-- | Sink a stream to 'System.IO.stdout'+sinkToStdOut :: MonadIO m => Streamer m String o ()+sinkToStdOut = sinkTell (liftIO . putStr)+{-# INLINE sinkToStdOut #-}++-- | @sink_ = forever await@ Simply discards all inputs. This may be+-- used to exhaust a stream solely for its effects.+sink_ :: Monad m => Streamer m i o ()+sink_ = awaits (const sink_)

@@ -0,0 +1,356 @@+{-# LANGUAGE LambdaCase #-}+-- | Streaming input and output.+module Hpp.Streamer (Streamer(..), StreamStep(..), Source, encase,+                     done, yield, yields, awaits, source, liftS,+                     nextOutput, run,+                     before, (~>), processPrefix, mapping, filtering, mapStream,+                     mappingMaybe, onDone, mapTil, flattenTil,+                     Chunky(..), metamorph) where+import Control.Applicative (Alternative(..))+import Control.Monad ((<=<))+import Data.Foldable (toList)+import Data.Void+import Hpp.Types (HasError(..), HasHppState(..), HasEnv(..))++-- * Streams of Steps++-- | Basic pipe.+data StreamStep r i o f = Await (i -> f) f+                        | Yield !o f+                        | Done (Maybe r)++instance Functor (StreamStep r i o) where+  fmap f (Await g d) = Await (f . g) (f d)+  fmap f (Yield o n) = Yield o (f n)+  fmap _ (Done r) = Done r+  {-# INLINE fmap #-}++-- | A stream of steps in a computational context.+newtype Streamer m i o r =+  Streamer { runStream :: m (StreamStep r i o (Streamer m i o r)) }++-- | A stream of steps that never awaits anything from upstream.+type Source m o r = Streamer m Void o r++-- | Package a step into a 'Streamer'+encase :: Monad m => StreamStep r i o (Streamer m i o r) -> Streamer m i o r+encase = Streamer . return+{-# INLINE encase #-}++instance Monad m => Functor (Streamer m i o) where+  fmap f (Streamer ma) = Streamer . flip fmap ma $ \case+    Await g d -> Await (fmap f . g) (fmap f d)+    Yield o n -> Yield o (fmap f n)+    Done r -> Done (fmap f r)+  {-# INLINE fmap #-}++instance Monad m => Applicative (Streamer m i o) where+  pure = Streamer . return . Done . Just+  {-# INLINE pure #-}+  Streamer ma <*> g = Streamer $ ma >>= \case+    Await f d -> return $ Await ((<*> g) . f) (d <*> g)+    Yield o n -> return $ Yield o (n <*> g)+    Done r -> maybe (runStream empty) (runStream . flip fmap g) r+  {-# INLINE (<*>) #-}++instance Monad m => Alternative (Streamer m r i) where+  empty = Streamer . return $ Done Nothing+  {-# INLINE empty #-}+  Streamer ma <|> b = Streamer . flip fmap ma $ \case+    Await g d -> Await ((<|> b) . g) (b <|> d)+    Yield o n -> Yield o (n <|> b)+    Done r -> Done r+  {-# INLINE (<|>) #-}++{-+-- This instance is quite often not really wanted due to associativity+-- issues.++instance Monad m => Monad (Streamer m r i) where+  return = pure+  {-# INLINE return #-}+  Streamer ma >>= fb = Streamer $ ma >>= \case+    Await f d -> return $ Await (\i -> f i >>= fb) (d >>= fb)+    Yield o n -> return $ Yield o (n >>= fb)+    Done r -> maybe (runStream empty) (runStream . fb) r+  {-# INLINE (>>=) #-}++instance Monad m => MonadPlus (Streamer m r i) where+  mzero = empty+  mplus = (<|>)+-}++instance (Monad m, HasError m) => HasError (Streamer m i o) where+  throwError = liftS . throwError+  {-# INLINE throwError #-}++instance (Monad m, HasHppState m) => HasHppState (Streamer m i o) where+  getState = liftS getState+  {-# INLINE getState #-}+  setState = liftS . setState+  {-# INLINE setState #-}++instance (Monad m, HasEnv m) => HasEnv (Streamer m i o) where+  getEnv = liftS getEnv+  {-# INLINE getEnv #-}+  setEnv = liftS . setEnv+  {-# INLINE setEnv #-}++-- * Builders++-- | Yield a value downstream, then finish.+yield :: Monad m => o -> Streamer m i o ()+yield o = encase $ Yield o (done ())+{-# INLINE yield #-}++-- | Yield a value then continue with another 'Streamer'.+yields :: Monad m => o -> Streamer m i o r -> Streamer m i o r+yields = (encase .) . Yield+{-# INLINE yields #-}++-- | Package a function that returns a 'Streamer' into a 'Streamer'.+awaits :: Monad m => (i -> Streamer m i o r) -> Streamer m i o r+awaits f = encase $ Await f empty+{-# INLINE awaits #-}++-- | The end of a stream.+done :: Monad m => r -> Streamer m i o r+done = pure+{-# INLINE done #-}++-- | Feed values downstream.+source :: (Monad m, Foldable f) => f a -> Streamer m i a ()+source = go . toList+  where go [] = done ()+        go (x:xs) = encase $ Yield x (go xs)+{-# INLINE source #-}++-- | Lift a monadic value into a 'Streamer'+liftS :: Functor m => m a -> Streamer m i o a+liftS = Streamer . fmap (Done . Just)+{-# INLINE liftS #-}++-- * Runners++-- | A source whose outputs have all been sunk may be run for its+-- effects and return value.+run :: Monad m => Source m Void r -> m (Maybe r)+run (Streamer s) = s >>= go+  where go (Done r) = return r+        go (Await _ _) = error "Source is awaiting in exhaustStreamer"+        go (Yield _ _) = error "A capped sink is yielding in exhaustStreamer"++-- | Compute the next step of a 'Streamer'.+nextOutput :: Monad m+           => Streamer m i o r -> m (Either (Maybe r) (o, Streamer m i o r))+nextOutput s = runStream s >>= go+  where go (Await _ n) = runStream n >>= go+        go (Yield o n) = return (Right (o, n))+        go (Done r) = return (Left r)++-- * Combinators++-- | Map a function over the values yielded by a stream.+mapStream :: Monad m => (a -> b) -> Streamer m i a r -> Streamer m i b r+mapStream f = go+  where go (Streamer s) = Streamer $ s >>= \case+          Done r -> pure $ Done r+          Await g e -> pure $ Await (go . g) (go e)+          Yield o n -> pure $ Yield (f o) (go n)+{-# INLINE[1] mapStream #-}++{-# RULES "hpp: mapStream/mapStream"+  forall f g s. mapStream f (mapStream g s) = mapStream (f . g) s #-}++-- | @upstream ~> downstream@ composes two streams such that values+-- flow from upstream to downstream.+(~>) :: Monad m => Streamer m a b r -> Streamer m b c r' -> Streamer m a c r'+src0 ~> Streamer mb = Streamer $ mb >>= goSnk src0+  where goSnk _ (Done r) = return $ Done r+        goSnk src (Yield o n) = return+                              $ Yield o (Streamer $ runStream n >>= goSnk src)+        goSnk src (Await f e) = runStream src >>= goSrc f e+        goSrc _ e (Done _) = runStream e >>= goSnk empty+        goSrc k _ (Yield i n) =  runStream (k i) >>= goSnk n+        goSrc k e (Await f' e') =+          return $ Await (\i -> Streamer $ runStream (f' i) >>= goSrc k e)+                         (e' ~> e)+{-# INLINE[1] (~>) #-}+infixl 9 ~>++_feedStreamer :: Monad m => Streamer m i o r -> [i] -> m ([i], [o], Maybe r)+_feedStreamer s xs0 = runStream s >>= aux xs0 id+  where aux [] acc (Await _ d) = runStream d >>= aux [] acc+        aux (x:xs) acc (Await f _) = runStream (f x) >>= aux xs acc+        aux xs acc (Yield o n) = runStream n >>= aux xs (acc . (o:))+        aux xs acc (Done r) = return (xs, acc [], r)++-- | @x `before` y@ runs @x@ to completion, discards its 'Done' value,+-- then becomes @y@.+before :: Monad m => Streamer m i o q -> Streamer m i o r -> Streamer m i o r+before (Streamer ma) mb = Streamer $ ma >>= go+  where go (Await f d) = return $ Await (\i -> Streamer $ runStream (f i) >>= go)+                                        (Streamer $ runStream d >>= go)+        go (Yield o n) = return $ Yield o (Streamer $ runStream n >>= go)+        go (Done _) = runStream mb++-- | Apply a function to the ending value of a stream.+onDone :: Monad m+       => (Maybe r -> Maybe r')+       -> Streamer m i o r+       -> Streamer m i o r'+onDone f (Streamer m) = Streamer $ m >>= go+  where go (Done r) = return $ Done (f r)+        go (Yield o n) = return $ Yield o (Streamer $ runStream n >>= go)+        go (Await f' e) = return $ Await (\i -> Streamer $ runStream (f' i) >>= go)+                                         (Streamer $ runStream e >>= go)+{-# INLINE[1] onDone #-}++{-# RULES "hpp: onDone/onDone"+  forall g f s. onDone g (onDone f s) = onDone (g . f) s #-}++-- | Apply a function to each value in a stream.+mapping :: Monad m => (a -> b) -> Streamer m a b r+mapping f = go+  where go = awaits (\i -> yields (f i) go)+        {-# INLINABLE go #-}+{-# INLINE[1] mapping #-}++{-# RULES "hpp: mapping/mapping"+  forall f g. mapping f ~> mapping g = mapping (g . f) #-}++-- | Discard all values that do not satisfy a predicate.+filtering :: Monad m => (a -> Bool) -> Streamer m a a r+filtering p = go+  where go = encase $ Await aux empty+        aux x = if p x then encase $ Yield x go else go+{-# INLINE[1] filtering #-}++-- | A combined filter and map.+mappingMaybe :: Monad m => (a -> Maybe b) -> Streamer m a b r+mappingMaybe f = go+  where go = awaits (\i -> maybe go (flip yields go) $ f i)+{-# INLINE[1] mappingMaybe #-}++predicateMap :: (a -> Bool) -> (a -> b) -> a -> Maybe b+predicateMap p f = \x -> if p x then Just (f x) else Nothing+{-# INLINE[1] predicateMap #-}++maybeNot :: (a -> Bool) -> Maybe a -> Maybe a+maybeNot p = \x -> case x of+                     Nothing -> Nothing+                     Just x' -> if p x' then x else Nothing+{-# INLINE[1] maybeNot #-}++{-# RULES "hpp: mapping ~> filtering"+  forall f p. mapping f ~> filtering p = mappingMaybe (maybeNot p . Just . f)+  ; "hpp: filtering ~> mapping"+  forall p f. filtering p ~> mapping f = mappingMaybe (predicateMap p f)+  ; "hpp: mappingMaybe ~> mappingMaybe"+  forall f g. mappingMaybe f ~> mappingMaybe g = mappingMaybe (f <=< g)+  #-}++-- | @processPrefix src snk@ is like '~>' except that when @snk@+-- finishes, the composite 'Streamer' becomes the remaining @src@.+processPrefix :: Monad m => Source m o r -> Streamer m o o r' -> Source m o r+processPrefix src0 snk = Streamer $ runStream snk >>= goSnk src0+  where goSnk src (Done _) = runStream src+        goSnk src (Yield o n) =+          return $ Yield o (Streamer $ runStream n >>= goSnk src)+        goSnk src (Await f _) = runStream src >>= goSrc f+        goSrc _ d@(Done _) = return d+        goSrc k (Yield i n) = runStream (k i) >>= goSnk n+        goSrc k (Await f e) =+          return $ Await (\i -> Streamer $ runStream (f i) >>= goSrc k)+                         (Streamer $ runStream e >>= goSrc k)++-- * Zoom support++-- | This is a left fold over a 'Streamer' with a final step to deal+-- with leftovers represented by whatever state the fold function+-- maintains.+common :: Monad m+       => (s -> Maybe (Streamer m i o ()))+       -> ((s -> Streamer m i o r -> Streamer m i' o' (Streamer m i o r))+            -> s -> Streamer m i o r -> Streamer m i' o' (Streamer m i o r))+       -> s+       -> Streamer m i o r -> Streamer m i' o' (Streamer m i o r)+common fin nxt = go+  where go acc src = encase $ Await (const (fin' acc src)) (nxt go acc src)+        fin' acc src = done . maybe src (`before` src) $ fin acc+{-# INLINABLE common #-}++-- | Flatten out chunks of inputs into individual values. The returned+-- 'Source' smuggles the remaining original 'Source' in an 'Await'+-- constructor, while the flattened source continues on with the+-- \"empty\" part of the 'Await' step. The upshot is that the value+-- may be used a regular 'Source', but it can also be swapped back+-- into the original 'Source'.+flattenTil :: Monad m+           => Source m [i] r -> Source m i (Source m [i] r)+flattenTil = common fin go []+  where fin acc = if null acc then Nothing else Just (yield acc)+        go k [] src = Streamer $ nextOutput src >>= \case+          Left r -> return $ Done (Just (encase (Done r)))+          -- Right (o,n) -> runStream $ go k o n+          Right (o,n) -> runStream $ go k o n+        go k (x:xs) src = encase $ Yield x (k xs src)+{-# INLINABLE flattenTil #-}++-- | See 'flattenTil' for an explanation.+mapTil :: Monad m+       => (a -> b)+       -> Streamer m Void a r+       -> Streamer m Void b (Streamer m Void a r)+mapTil f = common (const Nothing) go ()+  where go k () src = Streamer $ nextOutput src >>= \case+          Left r -> return $ Done (Just (encase (Done r)))+          Right (o, n) -> return $ Yield (f o) (k () n)+{-# INLINABLE mapTil #-}++-- * Chunky metamorphisms++-- | A function that produces an output stream that finishes with+-- another such function. Think of the input to this function as+-- coming from upstream, while the closure of the streamed output may+-- be used to thread state.+newtype Chunky m a b = Chunky (a -> Source m b (Chunky m a b))++-- | Apply a function to a 'Chunky''s output.+chunkMap :: Monad m => (b -> c) -> Chunky m a b -> Chunky m a c+chunkMap g (Chunky f) = Chunky (onDone (fmap (chunkMap g)) . mapStream g . f)+{-# INLINE[1] chunkMap #-}++{-# RULES "hpp: chunkMap/chunkMap"+  forall f g c. chunkMap f (chunkMap g c) = chunkMap (f . g) c #-}++-- | Apply a function to a 'Chunky's input.+chunkConmap :: Monad m => (a -> b) -> Chunky m b c -> Chunky m a c+chunkConmap g (Chunky f) = Chunky (onDone (fmap (chunkConmap g)) . f . g)+{-# INLINE[1] chunkConmap #-}++{-# RULES "hpp: chunkConmap/chunkConmap"+  forall f g c. chunkConmap f (chunkConmap g c) = chunkConmap (f . g) c #-}++-- | This is something like a composition of an unfold with a fold. We+-- fold the upstream values into some state carried by a 'Chunky',+-- then unfold that state in the 'Chunky''s output stream.+metamorph :: Monad m+          => Chunky m a b+          -> Streamer m a b ()+metamorph (Chunky f) = go+  where go = awaits (Streamer . aux . f)+        aux s = runStream s >>= \case+          Done (Just k) -> runStream $ metamorph k+          Done Nothing -> return $ Done Nothing+          Await _ _ -> error "Sources shouldn't await"+          Yield o n -> return $ Yield o (Streamer $ aux n)+{- INLINABLE metamorph #-}+-- inlining metamorph trips a bug in GHC-7.10.2++{-# RULES+    "hpp: metamorph/mapping"+    forall c f. metamorph c ~> mapping f = metamorph (chunkMap f c)+  ; "hpp: mapping/metamorph"+    forall c f. mapping f ~> metamorph c = metamorph (chunkConmap f c)+  #-}

@@ -1,6 +1,8 @@--- | Helpers for working with 'String's-module Hpp.String where+{-# LANGUAGE BangPatterns #-}+-- | HELPERS for working with 'String's+module Hpp.String (stringify, unquote, trimSpaces, breakOn, cons) where import Data.Char (isSpace)+import Data.List (isPrefixOf)  -- | Stringification puts double quotes around a string and -- backslashes before existing double quote characters and backslash@@ -32,3 +34,20 @@         go acc (c:cs)           | p c = go (acc . (c:)) cs           | otherwise = acc (c : go id cs)++-- | Similar to the function of the same name in the @text@ package.+--+-- @breakOn needle haystack@ finds the first instance of @needle@ in+-- @haystack@. The first component of the result is the prefix of+-- @haystack@ before @needle@ is matched. The second is the remainder of+-- @haystack@, starting with the match.+breakOn :: String -> String -> (String, String)+breakOn needle haystack = go 0 haystack+  where go _ [] = (haystack, [])+        go !i xs@(_:xs')+          | needle `isPrefixOf` xs = (take i haystack, xs)+          | otherwise = go (i+1) xs'++-- | Used to make switching to the @text@ package easier.+cons :: a -> [a] -> [a]+cons x xs = x : xs

@@ -15,16 +15,35 @@ detok :: Token -> String detok (Important s) = s detok (Other s) = s+{-# INLINE detok #-}  -- | 'True' if the given 'Token' is 'Important'; 'False' otherwise. isImportant :: Token -> Bool isImportant (Important _) = True isImportant _ = False +-- | 'True' if the given 'Token' is /not/ 'Important'; 'False'+-- otherwise.+notImportant :: Token -> Bool+notImportant (Other _) = True+notImportant _ = False+ -- | Return the contents of only 'Important' (non-space) tokens. importants :: [Token] -> [String] importants = map detok . filter isImportant +-- | Trim 'Other' 'Token's from both ends of a list of 'Token's.+trimUnimportant :: [Token] -> [Token]+trimUnimportant = aux id . dropWhile (not . isImportant)+  where aux _ [] = []+        aux acc (t@(Important _) : ts) = acc (t : aux id ts)+        aux acc (t@(Other _) : ts) = aux (acc . (t:)) ts++-- | Is a 'Token' a newline character?+newLine :: Token -> Bool+newLine (Other "\n") = True+newLine _ = False+ -- | Break a 'String' into space and non-whitespace runs. tokWords :: String -> [Token] tokWords [] = []@@ -43,17 +62,16 @@  -- | If you encounter a string literal, call this helper with a -- double-barreled continuation and the rest of your input. The--- continuation will be called with the remainder of the string--- literal as the first argument, and the remaining input as the--- second argument.+-- continuation will expect the remainder of the string literal as the+-- first argument, and the remaining input as the second argument. skipLiteral :: ((String -> String) -> String -> r) -> String -> r skipLiteral k = go ('"':)   where go acc ('\\':'\\':cs) = go (acc . ("\\\\"++)) cs         go acc ('\\':'"':cs) = go (acc . ("\\\""++)) cs-        -- go acc (c:'"':cs) = k (acc . ([c,'"']++)) cs         go acc ('"':cs) = k (acc . ('"':)) cs         go acc (c:cs) = go (acc . (c :)) cs         go acc [] = k acc []+{-# INLINE skipLiteral #-}  -- | @splits isDelimiter str@ tokenizes @str@ using @isDelimiter@ as a -- delimiter predicate. Leading whitespace is also stripped from@@ -94,3 +112,4 @@ -- . tokenize == id@. detokenize :: [Token] -> String detokenize = concatMap detok+{-# INLINE detokenize #-}

@@ -1,12 +1,22 @@-{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE FlexibleInstances, LambdaCase #-} -- | The core types involved used by the pre-processor. module Hpp.Types where+import Control.Monad (ap, join)+import Control.Monad.IO.Class (MonadIO, liftIO)+import Control.Monad.Trans.Class (MonadTrans, lift)+import Control.Monad.Trans.Except (ExceptT, throwE)+import Data.IORef (IORef, newIORef, readIORef, writeIORef)+-- import qualified Data.Map as M import Hpp.Config import Hpp.Tokens  -- | Line numbers are represented as 'Int's type LineNum = Int +-- | A macro binding environment.+type Env = [(String, Macro)]+-- type Env = M.Map String Macro+ -- * Errors  -- | Error conditions we may encounter.@@ -22,67 +32,143 @@            | BadMacroArguments LineNum String            | NoInputFile            | BadCommandLine String+           | RanOutOfInput              deriving (Eq, Ord, Show) +-- | Hpp can raise various parsing errors.+class HasError m where+  throwError :: Error -> m a++instance Monad m => HasError (ExceptT Error m) where+  throwError = throwE++instance (Monad m, HasHppState m) => HasHppState (ExceptT e m) where+  getState = lift getState+  {-# INLINE getState #-}+  setState = lift . setState+  {-# INLINE setState #-}++-- * Resource cleanup++-- | A cleanup action that is run at most once. To be used as an+-- abstract type with only 'runCleanup' and 'mkCleanup' as interface.+newtype Cleanup  = Cleanup (IORef (IO ()))++-- | Runs an action and replaces it with a nop+runCleanup :: Cleanup -> IO ()+runCleanup (Cleanup r) = join (readIORef r) >> writeIORef r (return ())++-- | @mkCleanup cleanup@ returns two things: a 'Cleanup' value, and an+-- action to neutralize that 'Cleanup'. In this way, the 'Cleanup'+-- value can be registered with a resource manager so that, in the+-- event of an error, the cleanup action is run, while the neutralizer+-- may be used to ensure that the registered 'Cleanup' action has no+-- effect if it is run. Typically one would neutralize a registered+-- cleanup action before performing a manual cleanup that subsumes the+-- registered cleanup.+mkCleanup :: IO () -> IO (Cleanup, IO ())+mkCleanup m = do r <- newIORef m+                 return $ (Cleanup r, writeIORef r (return ()))++-- * Free Monad Transformers++-- | Base functor for a free monad transformer+data FreeF f a r = PureF a | FreeF (f r)++instance Functor f => Functor (FreeF f a) where+  fmap _ (PureF x) = PureF x+  fmap f (FreeF x) = FreeF $ fmap f x+  {-# INLINE fmap #-}+ -- * Pre-processor Actions +-- | Dynamic state of the preprocessor engine.+data HppState = HppState { hppConfig :: Config+                         , hppLineNum :: LineNum+                         , hppCleanups :: [Cleanup]+                         , hppEnv :: Env }+ -- | A free monad construction to strictly delimit what capabilities -- we need to perform pre-processing.-data Hpp a = Pure a-           | ReadFile Int FilePath (String -> Hpp a)-           | ReadNext Int FilePath (String -> Hpp a)-           | GetConfig (Config -> Hpp a)-           | SetConfig Config (Hpp a)+data HppF t r = ReadFile Int FilePath (t -> r)+              | ReadNext Int FilePath (t -> r)+              | GetState (HppState -> r)+              | SetState HppState r+              | ThrowError Error -instance Functor Hpp where-  fmap f (Pure a) = Pure (f a)-  fmap f (ReadFile ln file k) = ReadFile ln file (fmap f . k)-  fmap f (ReadNext ln file k) = ReadNext ln file (fmap f . k)-  fmap f (GetConfig k) = GetConfig (fmap f . k)-  fmap f (SetConfig cfg k) = SetConfig cfg (fmap f k)+instance Functor (HppF t) where+  fmap f (ReadFile ln file k) = ReadFile ln file (f . k)+  fmap f (ReadNext ln file k) = ReadNext ln file (f . k)+  fmap f (GetState k) = GetState (f . k)+  fmap f (SetState cfg k) = SetState cfg (f k)+  fmap _ (ThrowError e) = ThrowError e+  {-# INLINE fmap #-} -instance Applicative Hpp where-  pure = Pure-  Pure f <*> Pure x = Pure (f x)-  Pure f <*> ReadFile ln file k = ReadFile ln file (fmap f . k)-  Pure f <*> ReadNext ln file k = ReadNext ln file (fmap f . k)-  Pure f <*> GetConfig k = GetConfig (fmap f . k)-  Pure f <*> SetConfig cfg k = SetConfig cfg (fmap f k)-  ReadFile ln file k <*> x = ReadFile ln file ((<*> x) . k)-  ReadNext ln file k <*> x = ReadNext ln file ((<*> x) . k)-  GetConfig k <*> x = GetConfig ((<*> x) . k)-  SetConfig cfg k <*> x = SetConfig cfg (k <*> x)+-- * Hpp Monad Transformer -instance Monad Hpp where+-- | 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)) }++instance Functor m => Functor (HppT t m) where+  fmap f (HppT x) = HppT $ fmap f' x+    where f' (PureF y) = PureF (f y)+          f' (FreeF y) = FreeF $ fmap (fmap f) y+  {-# INLINE fmap #-}++instance Monad m => Applicative (HppT t m) where+  pure = HppT . pure . PureF+  {-# INLINE pure #-}+  (<*>) = ap+  {-# INLINE (<*>) #-}++instance Monad m => Monad (HppT t m) where   return = pure-  Pure x >>= f = f x-  ReadFile ln file k >>= f = ReadFile ln file ((>>= f) . k)-  ReadNext ln file k >>= f = ReadNext ln file ((>>= f) . k)-  GetConfig k >>= f = GetConfig ((>>= f) . k)-  SetConfig cfg k >>= f = SetConfig cfg (k >>= f)+  {-# INLINE return #-}+  HppT ma >>= fb = HppT $ ma >>= \case+                     PureF x -> runHppT $ fb x+                     FreeF x -> return . FreeF $ fmap (>>= fb) x+  {-# INLINE (>>=) #-} --- | An 'Hpp' action that can fail.-newtype ErrHpp a = ErrHpp { runErrHpp :: Hpp (Either (FilePath,Error) a) }+instance MonadTrans (HppT t) where+  lift = HppT . fmap PureF+  {-# INLINE lift #-} -instance Functor ErrHpp where-  fmap f = ErrHpp . fmap (fmap f) . runErrHpp+instance MonadIO m => MonadIO (HppT t m) where+  liftIO = HppT . fmap PureF . liftIO+  {-# INLINE liftIO #-} -instance Applicative ErrHpp where-  pure = ErrHpp . pure . pure-  ErrHpp f <*> ErrHpp x =-    ErrHpp $-    do f >>= \case-         Left err -> return (Left err)-         Right f' -> do x >>= \case-                          Left err' -> return (Left err')-                          Right x' -> return (Right $ f' x')+-- | An interpreter capability to modify dynamic state.+class HasHppState m where+  getState :: m HppState+  setState :: HppState -> m () -instance Monad ErrHpp where-  return = pure-  ErrHpp x >>= fb = ErrHpp $ do x >>= \case-                                  Left err -> return (Left err)-                                  Right x' -> runErrHpp (fb x')+instance Monad m => HasHppState (HppT t m) where+  getState = HppT . pure . FreeF $ GetState pure+  {-# INLINE getState #-}+  setState s = HppT . pure . FreeF $ SetState s (pure ())+  {-# INLINE setState #-} +-- | An interpreter capability of threading a binding environment.+class HasEnv m where+  getEnv :: m Env+  setEnv :: Env -> m ()++instance Monad m => HasEnv (HppT t m) where+  getEnv = fmap hppEnv getState+  {-# INLINE getEnv #-}+  setEnv e = getState >>= setState . (\s -> s { hppEnv = e })+  {-# INLINE setEnv #-}++instance Applicative m => HasError (HppT t m) where+  throwError = HppT . pure . FreeF . ThrowError+  {-# INLINE throwError #-}++instance (HasEnv m, Monad m) => HasEnv (ExceptT e m) where+  getEnv = lift getEnv+  {-# INLINE getEnv #-}+  setEnv = lift . setEnv+  {-# INLINE setEnv #-}+ -- * Expansion  -- | Macro expansion involves treating tokens differently if they@@ -100,11 +186,7 @@           | Mask String           | Scan Token           | Rescan Token-            deriving Show---- | A difference list is a list representation with @O(1)@ @snoc@'ing at--- the end of the list.-type DList a = [a] -> [a]+            deriving (Eq, Show)  -- * Macros 

@@ -1,13 +1,6 @@ {-# LANGUAGE LambdaCase #-}-import Control.Monad (join, unless)-import Hpp-import Hpp.Config-import Hpp.Env (Env, deleteKey)-import Hpp.Tokens-import Hpp.Types (Error(..))-import System.Directory (doesFileExist)+import Hpp.CmdLine import System.Environment-import System.FilePath (splitFileName)  usage :: IO () usage = mapM_ putStrLn@@ -33,112 +26,26 @@   , "  macro definitions are kept."   , "--cpp"   , "  C98 compatibility. Implies: --fline-splice --ferase-comments"-  , "  --fapplication-splice -D __STDC__ "-  , "  -D __STDC_VERSION__=199409L -D _POSIX_C_SOURCE=200112L"+  , "  -D __STDC__  -D __STDC_VERSION__=199409L -D _POSIX_C_SOURCE=200112L"   , "--fline-splice"   , "  Enable continued line splicing."   , "--ferase-comments"-  , "  Remove all C-style comments before processing."-  , "--fapplication-splice"-  , "  Support multi-line function applications." ]--breakEqs :: String -> [String]-breakEqs = aux . break (== '=')-  where aux (h,[]) = [h]-        aux (h,'=':t) = [h,"=",t]-        aux _ = error "breakEqs broke"---- | If no space is included between a switch and its argument, break--- it into two tokens to simplify parsing.-splitSwitches :: String -> [String]-splitSwitches ('-':'I':t@(_:_)) = ["-I",t]-splitSwitches ('-':'D':t@(_:_)) = ["-D",t]-splitSwitches ('-':'U':t@(_:_)) = ["-U",t]-splitSwitches ('-':'o':t@(_:_)) = ["-o",t]-splitSwitches x = [x]---- FIXME: Defining function macros probably doesn't work here.-parseArgs :: ConfigF Maybe -> [String]-          -> IO (Either Error (Env, [String], Config, Maybe FilePath))-parseArgs cfg0 = go [] id cfg0 Nothing . concatMap breakEqs-  where go env acc cfg out [] =-          case realizeConfig cfg of-            Just cfg' -> return (Right (env, acc [], cfg', out))-            Nothing -> return (Left NoInputFile)-        go env acc cfg out ("-D":name:"=":body:rst) =-          case parseDefinition (Important name : Other " " : tokenize body) of-            Nothing -> return . Left $ BadMacroDefinition 0-            Just def -> go (def:env) acc cfg out rst-        go env acc cfg out ("-D":name:rst) =-          case parseDefinition ([Important name, Other " ", Important "1"]) of-            Nothing -> return . Left $ BadMacroDefinition 0-            Just def -> go (def:env) acc cfg out rst-        go env acc cfg out ("-U":name:rst) =-          go (deleteKey name env) acc cfg out rst-        go env acc cfg out ("-I":dir:rst) =-          let cfg' = cfg { includePathsF = fmap (++[dir]) (includePathsF cfg) }-          in go env acc cfg' out rst-        go env acc cfg out ("-include":file:rst) =-          let ln = "#include \"" ++ file ++ "\""-          in go env (acc . (ln:)) cfg out rst-        go env acc cfg out ("--cpp":rst) =-          let cfg' = cfg { spliceLongLinesF = Just True-                         , eraseCCommentsF = Just True-                         , spliceApplicationsF = Just True }-              defs = concatMap ("-D":)-                       [ ["__STDC__"]-                         -- __STDC_VERSION__ is only defined in C94 and later-                       , ["__STDC_VERSION__","=","199409L"]-                       , ["_POSIX_C_SOURCE","=","200112L"] ]-          in go env acc cfg' out (defs ++ rst)-        go env acc cfg out ("--fline-splice":rst) =-          go env acc (cfg { spliceLongLinesF = Just True }) out rst-        go env acc cfg out ("--ferase-comments":rst) =-          go env acc (cfg { eraseCCommentsF = Just True }) out rst-        go env acc cfg out ("--fapplication-splice":rst) =-          go env acc (cfg { spliceApplicationsF = Just True }) out rst-        go env acc cfg _ ("-o":file:rst) =-          go env acc cfg (Just file) rst-        go env acc cfg out ("-x":_lang:rst) =-          go env acc cfg out rst -- We ignore source language specification-        go env acc cfg Nothing (file:rst) =-          case curFileNameF cfg of-            Nothing -> go env acc (cfg { curFileNameF = Just file }) Nothing rst-            Just _ -> go env acc cfg (Just file) rst-        go _ _ _ (Just _) _ =-          return . Left $ BadCommandLine "Multiple output files given"+  , "  Remove all C-style comments before processing." ]  main :: IO () main = do getArgs >>= \case             [] -> usage-            args -> do cfgNow <- defaultConfigFNow-                       let args' = concatMap splitSwitches args-                       (env,lns,cfg,outPath) <- fmap (either (error . show) id)-                                                     (parseArgs cfgNow args')-                       exists <- doesFileExist (curFileName cfg)-                       unless exists . error $-                         "Couldn't open input file: "++curFileName cfg-                       let (_dir,fileName) = splitFileName $ curFileName cfg-                           cfg' = cfg { curFileNameF = pure fileName }-                       join . runErrHppIO cfg' $-                         do src <- liftHpp . hppReadFile 0-                                   $ '"' : curFileName cfg ++ "\""-                            -                            (_,r) <- preprocess env (unlines lns ++ src)-                            case outPath of-                              Nothing -> return (putStrLn r)-                              Just f -> return (writeFile f r)+            args -> runWithArgs args   {-  For testing against C: -hpp -I/usr/local/include -I/usr/include -fline-splice -ferase-comments -fapplication-splice -D __x86_64__ -D __GNUC__ -D _POSIX_C_SOURCE n_1.c+hpp -I/usr/local/include -I/usr/include -fline-splice -ferase-comments -D __x86_64__ -D __GNUC__ -D _POSIX_C_SOURCE n_1.c  For the mcpp validation suite -../tool/cpp_test HPP "../../dist/build/hpp/hpp -I/usr/local/include -I/usr/include -fline-splice -ferase-comments -fapplication-splice -D __x86_64__ -D __GNUC__=4 -D __STDC__ -D __STDC_VERSION__=199409L -D _POSIX_C_SOURCE -D __DARWIN_ONLY_UNIX_CONFORMANCE %s.c | gcc -o %s -x c -" "rm %s" < n_i_.lst -+../tool/cpp_test HPP "../../dist/build/hpp/hpp -I/usr/local/include -I/usr/include -fline-splice -ferase-comments -D __x86_64__ -D __GNUC__=4 -D __STDC__ -D __STDC_VERSION__=199409L -D _POSIX_C_SOURCE -D __DARWIN_ONLY_UNIX_CONFORMANCE %s.c | gcc -o %s -x c -" "rm %s" < n_i_.lst   -}