hpp 0.3.1.0 → 0.4.0

raw patch · 18 files changed

+1198/−1234 lines, 18 filesdep +bytestringdep +bytestring-triedep +ghc-primPVP ok

version bump matches the API change (PVP)

Dependencies added: bytestring, bytestring-trie, ghc-prim, semigroups

API changes (from Hackage documentation)

Files

• CHANGELOG.md +9/−0
• README.md +32/−0
• hpp.cabal +13/−44
• src/Hpp.hs +394/−451
• src/Hpp/CmdLine.hs +29/−15
• src/Hpp/Config.hs +8/−2
• src/Hpp/Env.hs +20/−1
• src/Hpp/Expansion.hs +56/−48
• src/Hpp/Expr.hs +10/−10
• src/Hpp/Parser.hs +122/−107
• src/Hpp/StreamIO.hs +0/−70
• src/Hpp/Streamer.hs +0/−356
• src/Hpp/String.hs +14/−11
• src/Hpp/StringSig.hs +213/−0
• src/Hpp/Tokens.hs +131/−57
• src/Hpp/Types.hs +128/−56
• src/Main.hs +8/−3
• tests/mcpp-validation.sh +11/−3

@@ -1,3 +1,12 @@+# 0.4.0++- Simplify the parsing machinery+- Don't remove C++-style single-line comments+- Don't error on unknown cpp directives+  Previously, a line beginning with "#-}" would cause an error+- Don't do trigraph replacement by default.+  Haskell allows "??" in operator names and you can be sure `lens` uses it!+ # 0.3.1  Address a change wherein GHC 8 will pass `-include` arguments without a space between "-include" and the file to be included.

@@ -0,0 +1,32 @@+`hpp` is a Haskell pre-processor that is also a C90-compatible+pre-processor (with the addition of a `--cpp` flag). It is+packaged as both a library and an executable.++To use as a Haskell preprocessor for resolving `#ifdef` conditionals+and macro expansion, an invocation might look like,++```+hpp -DDEBUG Foo.hs+```++To use as a C preprocessor, an invocation might look like,++```+hpp -DDEBUG --cpp foo.c+```++To have GHC use `hpp` as the C pre-processor, add this line to the top+of a Haskell source file that makes use of the `CPP` `LANGUAGE`+pragma,++```+{-# OPTIONS_GHC -cpp -pgmPhpp #-}+```++Or add this line to your `.cabal` file:++```+ghc-options: -pgmPhpp+```++Note that you will need to ensure that the `hpp` executable is available in your build environment (e.g. you can add `hpp` as a `build-depends` in your `.cabal` file).

@@ -1,51 +1,19 @@ name:                hpp-version:             0.3.1.0+version:             0.4.0 synopsis:            A Haskell pre-processor--description: @hpp@ is a Haskell pre-processor that is also a-             C89/C90-compatible pre-processor (with the addition of a-             @--cpp@ flag). It is packaged as both a library and-             an executable.--             .--             To use as a Haskell preprocessor for resolving @#ifdef@-             conditionals and simple macro expansion while still-             allowing multi-line string literals, an invocation might-             look like,-             .-             @-             hpp -DDEBUG Foo.hs-             @-             .-             To use as a C preprocessor, an invocation might look-             like,-             .-             @-             hpp -DDEBUG --cpp foo.c-             @-             .--             To have GHC use @hpp@ as the C pre-processor, add this-             line to the top of a Haskell source file that makes use-             of the @CPP@ @LANGUAGE@ pragma.-             .--             @-             &#123;-\# OPTIONS_GHC -cpp -pgmPhpp -optP\-\-cpp \#-&#125;-             @--+description:         See the README for usage examples license:             BSD3 license-file:        LICENSE author:              Anthony Cowley maintainer:          acowley@gmail.com-copyright:           (C) 2015 Anthony Cowley+copyright:           (C) 2015-2016 Anthony Cowley category:            Development build-type:          Simple-extra-source-files:  tests/mcpp-validation.sh, CHANGELOG.md+extra-source-files:  tests/mcpp-validation.sh, CHANGELOG.md, README.md cabal-version:       >=1.10 homepage:            https://github.com/acowley/hpp+tested-with:         GHC == 7.10.3, GHC == 8.0.1+ source-repository head   type:     git   location: http://github.com/acowley/hpp.git@@ -58,18 +26,19 @@                        Hpp.Expansion,                        Hpp.Expr,                        Hpp.Parser,-                       Hpp.Streamer,-                       Hpp.StreamIO,                        Hpp.String,+                       Hpp.StringSig,                        Hpp.Tokens,                        Hpp.Types   build-depends:       base >=4.8 && <4.10, directory, time >=1.5, filepath,-                       transformers >=0.4+                       transformers >=0.4, bytestring, bytestring-trie, ghc-prim++  if impl(ghc < 8)+    build-depends: semigroups >= 0.18 && < 0.19+   hs-source-dirs:      src   default-language:    Haskell2010-  ghc-options: -Wall -fno-full-laziness-  -- ghc-options: -Wall -fprof-auto -fno-full-laziness -ddump-simpl -ddump-to-file---  -ddump-simpl-stats+  ghc-options: -Wall  executable hpp   main-is:             src/Main.hs

@@ -1,39 +1,37 @@-{-# LANGUAGE BangPatterns, ConstraintKinds, LambdaCase, RankNTypes,-             ScopedTypeVariables, GeneralizedNewtypeDeriving #-}+{-# LANGUAGE BangPatterns, ConstraintKinds, LambdaCase, OverloadedStrings,+             ScopedTypeVariables, TupleSections, ViewPatterns #-} -- | Front-end interface to the pre-processor.-module Hpp (parseDefinition, preprocess, yield, before, source,-            hppReadFile, hppIO, hppRegisterCleanup,-            streamHpp, sinkToFile, sinkToStdOut, (~>), HppCaps) where-import Control.Applicative (empty)+module Hpp (parseDefinition, preprocess,+            hppReadFile, hppIO, HppCaps, hppFileContents) where+import Control.Arrow (first) import Control.Monad (unless)+import Control.Monad.Trans.Class (lift)+import Control.Monad.Trans.Except import Control.Monad.IO.Class (MonadIO, liftIO)-import Control.Monad.Trans.State.Strict (runStateT)+import Control.Monad.Trans.State.Strict (StateT, evalStateT) import Data.Char (isSpace)-import Data.Foldable (traverse_)-import Data.Functor.Constant-import Data.Functor.Identity-import Data.List (isPrefixOf, uncons)+import Data.IORef+import Data.Maybe (fromMaybe) import Data.Monoid ((<>))-import Data.Void (Void)+import Data.String (fromString) import Hpp.Config (Config, curFileNameF, curFileName, includePaths,-                   eraseCComments, spliceLongLines, inhibitLinemarkers)-import Hpp.Env (deleteKey, emptyEnv, insertPair, lookupKey)+                   eraseCComments, spliceLongLines, inhibitLinemarkers,+                   replaceTrigraphs)+import Hpp.Env (deleteKey, 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.Parser (Parser, ParserT, replace, await, awaitJust, droppingWhile,+                   precede, takingWhile, insertInputSegment, onElements,+                   evalParse, onInputSegment)+import Hpp.StringSig import Hpp.Tokens (Token(..), importants, isImportant, newLine, trimUnimportant,                    detokenize, notImportant, tokenize, skipLiteral) import Hpp.Types import System.Directory (doesFileExist) import System.FilePath ((</>)) import Text.Read (readMaybe)+import Prelude hiding (String)+import qualified Prelude as P  -- * Trigraphs @@ -52,113 +50,94 @@             , ('>', '}')             , ('-', '~') ] -trigraphReplacement :: String -> String-trigraphReplacement = aux . breakOn "??"-  where aux (s,[]) = s-        aux (h,t) =-          case uncons (drop 2 t) of-            Nothing -> h <> "??"-            Just (c,t') -> +trigraphReplacement :: Stringy s => s -> s+trigraphReplacement s = aux (breakOn [("??", ())] s)+  where aux Nothing = s+        aux (Just (_, pre, pos)) =+          case uncons pos of+            Nothing -> pre <> "??"+            Just (c,t) ->               case lookup c trigraphs of-                Just c' -> h <> cons c' (trigraphReplacement t')-                Nothing -> h <> "?" <> trigraphReplacement (cons '?' (cons c t'))+                Just c' -> snoc pre c' <> trigraphReplacement t+                Nothing -> snoc pre '?' <> trigraphReplacement (cons '?' pos)  -- * Line Splicing --- | 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')- -- | 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)+lineSplicing :: Stringy s => [s] -> [s]+lineSplicing = go id+  where go acc [] = [acc mempty]+        go acc (ln:lns) = case unsnoc ln of+                            Nothing -> acc mempty : go id lns+                            Just (ini, '\\') -> go (acc . (ini<>)) lns+                            Just _ -> acc ln : go id lns {-# INLINE lineSplicing #-}  -- * C Comments -breakBlockCommentStart :: String -> Maybe (String, String)-breakBlockCommentStart = go id-  where go _ [] = Nothing-        go acc ('"' : ts) = skipLiteral (go . (acc .)) ts-        go acc ('/' : '*' : t) = Just (acc [], t)-        go acc (c:cs) = go (acc . (c:)) cs--breakBlockCommentEnd :: String -> Maybe String-breakBlockCommentEnd [] = Nothing-breakBlockCommentEnd (_:'"':cs) = skipLiteral (const breakBlockCommentEnd) cs-breakBlockCommentEnd ('*':'/':t) = Just (' ':t)-breakBlockCommentEnd (_:cs) = breakBlockCommentEnd cs+breakBlockCommentStart :: Stringy s => s -> Maybe (s, s)+breakBlockCommentStart s =+  case breakCharOrSub '"' "/*" s of+    NoMatch -> Nothing+    CharMatch pre pos -> let (lit, rest) = skipLiteral pos+                         in first ((pre <> lit) <>) <$>+                            breakBlockCommentStart rest+    SubMatch pre pos -> Just (pre, pos) -dropOneLineBlockComments :: String -> String-dropOneLineBlockComments [] = []-dropOneLineBlockComments (c:'"':cs) =-  c : skipLiteral (\x y -> x [] ++ dropOneLineBlockComments y) cs-dropOneLineBlockComments ('/':'*':cs) = go cs-  where go [] = "/*"-        go ('*':'/':t)-          | all isSpace t = t-          | otherwise = ' ' : dropOneLineBlockComments t-        go (_:t) = go t-dropOneLineBlockComments (c:cs) = c : dropOneLineBlockComments cs+breakBlockCommentEnd :: Stringy s => s -> Maybe s+breakBlockCommentEnd s =+  case breakCharOrSub '"' "*/" s of+    NoMatch -> Nothing+    CharMatch _ pos -> let (_, rest) = skipLiteral pos+                       in breakBlockCommentEnd rest+    SubMatch _ pos -> Just pos -dropLineComments :: String -> String-dropLineComments = fst . breakOn "//"+dropOneLineBlockComments :: Stringy s => s -> s+dropOneLineBlockComments s =+  case breakCharOrSub '"' "/*"s of+    NoMatch -> s+    CharMatch pre pos ->+      let (lit,rest) = skipLiteral pos+      in snoc pre '"' <> lit <> dropOneLineBlockComments rest+    SubMatch pre pos ->+      case breakOn [("*/", ())] pos of+        Nothing -> pre <> "/*"+        Just (_,_,pos') -> snoc pre ' ' <> dropOneLineBlockComments pos' -removeMultilineComments :: Monad m => Int -> Streamer m String String ()-removeMultilineComments !lineStart = metamorph (Chunky $ goStart lineStart)-  where goStart !curLine ln =+removeMultilineComments :: Stringy s => Int -> [s] -> [s]+removeMultilineComments !lineStart = goStart lineStart+  where goStart _ [] = []+        goStart !curLine (ln:lns) =           case breakBlockCommentStart ln of-            Nothing -> yields ln (done . Chunky $ goStart (curLine+1))-            Just (pre,_) -> done . Chunky $ goEnd (curLine+1) pre-        goEnd !curLine pre ln =+            Nothing -> ln : goStart (curLine+1) lns+            Just (pre,_) -> goEnd (curLine+1) pre lns+        goEnd _ _ [] = error "Unmatched /*"+        goEnd !curLine pre (ln:lns) =           case breakBlockCommentEnd ln of-            Nothing -> done (Chunky $ goEnd (curLine+1) pre)+            Nothing -> goEnd (curLine+1) pre lns             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))--              -- 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 #-}+              | sall isSpace (pre<>pos) ->+                ("#line "<> fromString (show (curLine+1))) : goStart (curLine + 1) lns+              | otherwise -> (pre<>pos)+                             : ("#line "<> fromString (show (curLine+1)))+                             : goStart (curLine+1) lns -commentRemoval :: Monad m => Streamer m String String ()-commentRemoval =  mapping dropOneLineBlockComments-               ~> removeMultilineComments 1-               ~> mapping dropLineComments+commentRemoval :: Stringy s => [s] -> [s]+commentRemoval = removeMultilineComments 1 . map dropOneLineBlockComments --- * Token Splices+-- * TOKEN Splices  -- | Deal with the two-character '##' token pasting/splicing -- operator. We do so eliminating spaces around the @##@ -- operator.-prepTokenSplices :: [Token] -> [Token]-prepTokenSplices = dropSpaces [] . mergeTokens []+prepTOKENSplices :: [TOKEN] -> [TOKEN]+prepTOKENSplices = map (fmap copy) . dropSpaces [] . mergeTOKENs []   where -- Merges ## tokens, and reverses the input list-        mergeTokens acc [] = acc-        mergeTokens acc (Important "#" : Important "#" : ts) =-          mergeTokens (Important "##" : acc) (dropWhile (not . isImportant) ts)-        mergeTokens acc (t:ts) = mergeTokens (t : acc) ts+        mergeTOKENs acc [] = acc+        mergeTOKENs acc (Important "#" : Important "#" : ts) =+          mergeTOKENs (Important "##" : acc) (dropWhile (not . isImportant) ts)+        mergeTOKENs acc (t:ts) = mergeTOKENs (t : acc) ts         -- Drop trailing spaces and re-reverse the list         dropSpaces acc [] = acc         dropSpaces acc (t@(Important "##") : ts) =@@ -170,142 +149,134 @@ -- | @functionMacro parameters body arguments@ substitutes @arguments@ -- for @parameters@ in @body@ and performs stringification for uses of -- the @#@ operator and token concatenation for the @##@ operator.-functionMacro :: [String] -> [Token] -> [([Scan],String)] -> [Scan]+functionMacro :: [String] -> [TOKEN] -> [([Scan],String)] -> [Scan] functionMacro params body = paste                           . subst body'                           -- . M.fromList-                          . zip params-  where subst toks gamma = go toks+                          . zip params'+  where params' = map copy params+        subst toks gamma = go toks           where go [] = []                 go (p@(Important "##"):t@(Important s):ts) =-                  case lookupKey s gamma of+                  case lookup s gamma of                     Nothing -> Rescan p : Rescan t : go ts-                    Just ((_,arg),_) ->+                    Just (_,arg) ->                       Rescan p : Rescan (Important arg) : go ts                 go (t@(Important s):p@(Important "##"):ts) =-                  case lookupKey s gamma of+                  case lookup s gamma of                     Nothing -> Rescan t : go (p:ts)-                    Just ((_,arg),_) -> Rescan (Important arg) : go (p:ts)+                    Just (_,arg) -> Rescan (Important arg) : go (p:ts)                 go (t@(Important "##"):ts) = Rescan t : go ts-                go (t@(Important ('#':s)) : ts) =-                  case lookupKey s gamma of+                go (t@(Important ('#':.s)) : ts) =+                  case lookup s gamma of                     Nothing -> Rescan t : go ts-                    Just ((_,arg),_) ->+                    Just (_,arg) ->                       Rescan (Important (stringify arg)) : go ts                 go (t@(Important s) : ts) =-                  case lookupKey s gamma of+                  case lookup s gamma of                     Nothing -> Rescan t : go ts-                    Just ((arg,_),_) -> arg ++ go ts+                    Just (arg,_) -> arg ++ go ts                 go (t:ts) = Rescan t : go ts         prepStringify [] = []         prepStringify (Important "#" : ts) =           case dropWhile (not . isImportant) ts of-            (Important t : ts') -> Important ('#':t) : prepStringify ts'+            (Important t : ts') -> Important (cons '#' t) : prepStringify ts'             _ -> Important "#" : ts         prepStringify (t:ts) = t : prepStringify ts-                    -        body' = prepStringify . prepTokenSplices $++        body' = prepStringify . prepTOKENSplices $                 dropWhile (not . isImportant) body         paste [] = []         paste (Rescan (Important s) : Rescan (Important "##")               : Rescan (Important t) : ts) =-          paste (Rescan (Important (trimSpaces s ++ dropWhile isSpace t)) : ts)+          paste (Rescan (Important (trimSpaces s <> sdropWhile isSpace t)) : ts)         paste (t:ts) = t : paste ts  -- * Pre-Processor Capabilities -config :: Lens HppState Config-config f (HppState cfg ln cln e) = (\cfg' -> HppState cfg' ln cln e) <$> f cfg--lineNum :: Lens HppState LineNum-lineNum f (HppState cfg ln cln e) = (\ln' -> HppState cfg ln' cln e) <$> f ln--cleanups :: Lens HppState [Cleanup]-cleanups f (HppState cfg ln cln e) = (\cln' -> HppState cfg ln cln' e) <$> f cln--env :: Lens HppState Env-env f (HppState cfg ln cln e) = (\e' -> HppState cfg ln cln e') <$> f e- modifyState :: (Monad m, HasHppState m) => (HppState -> HppState) -> m () modifyState f = getState >>= setState . f  -- | Run a Stream with a configuration for a new file. streamNewFile :: (Monad m, HasHppState m)-              => FilePath-              -> Source m o ()-              -> Source m o ()-streamNewFile fp s = Streamer $+              => FilePath -> [[TOKEN]] -> Parser m [TOKEN] ()+streamNewFile fp s =   do (oldCfg,oldLine) <- do st <- getState                             let cfg = hppConfig st                                 cfg' = cfg { curFileNameF = pure fp }                                 ln = hppLineNum st                             setState (st {hppConfig = cfg', hppLineNum = 1})                             return (cfg, ln)-     runStream $-       before s (liftS $ modifyState (setL lineNum oldLine . setL config oldCfg))+     insertInputSegment+       s (modifyState (setL lineNum oldLine . setL config oldCfg)) --- * Running an Hpp Action+-- * Finding @include@ files -includeCandidates :: [FilePath] -> String -> Maybe [FilePath]+includeCandidates :: [FilePath] -> P.String -> Maybe [FilePath] includeCandidates searchPath nm =   case nm of     '<':nm' -> Just $ sysSearch (init nm')     '"':nm' -> let nm'' = init nm'-               in Just $ nm'' : sysSearch nm''+                in Just $ nm'' : sysSearch nm''     _ -> Nothing   where sysSearch f = map (</> f) searchPath -searchForInclude :: [FilePath] -> String -> IO (Maybe FilePath)+searchForInclude :: [FilePath] -> P.String -> IO (Maybe FilePath) searchForInclude paths = maybe (return Nothing) aux . includeCandidates paths   where aux [] = return Nothing         aux (f:fs) = do exists <- doesFileExist f                         if exists then return (Just f) else aux fs -searchForNextInclude :: [FilePath] -> String -> IO (Maybe FilePath)+searchForNextInclude :: [FilePath] -> P.String -> IO (Maybe FilePath) searchForNextInclude paths = maybe (return Nothing) (aux False)                            . includeCandidates paths   where aux _ [] = return Nothing         aux n (f:fs) = do exists <- doesFileExist f                           if exists-                          then if n -                               then return (Just f) +                          then if n+                               then return (Just f)                                else aux True fs                           else aux n fs -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)+-- * Running an Hpp Action++runHpp :: forall m a src. (MonadIO m, HasHppState m)+       => (FilePath -> m src)+       -> (src -> m ())+       -> HppT src m a+       -> m (Either (FilePath,Error) a)+runHpp source sink m = runHppT m >>= go+  where go :: FreeF (HppF src) a (HppT src m a)+           -> m (Either (FilePath, Error) a)+        go (PureF x) = return $ Right x         go (FreeF s) = case s of           ReadFile ln file k ->-            liftIO (searchForInclude (includePaths cfg) file)-            >>= readAux ln file (HppStream . k)+            (includePaths <$> use config)+            >>= liftIO . flip searchForInclude file+            >>= readAux ln file 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+            (includePaths <$> use config)+            >>= liftIO . flip searchForNextInclude file+            >>= readAux ln file k+          WriteOutput output k -> sink output >> runHppT k >>= go+         readAux ln file _ Nothing =-          return $ Left (curFile, IncludeDoesNotExist ln file)-        readAux _ln _file k (Just file') = runHpp readInput st (readInput file' >>= k)-        cfg = hppConfig st+          Left . (, IncludeDoesNotExist ln file) . curFileName <$> use config+        readAux _ln _file k (Just file') =+          source file' >>= runHppT . k >>= go+{-# SPECIALIZE runHpp ::+    (FilePath -> Parser (StateT HppState (ExceptT Error IO)) [TOKEN] [String])+ -> ([String] -> Parser (StateT HppState (ExceptT Error IO)) [TOKEN] ())+ -> HppT [String] (Parser (StateT HppState (ExceptT Error IO)) [TOKEN]) a+ -> Parser (StateT HppState (ExceptT Error IO)) [TOKEN] (Either (FilePath,Error) a) #-}  -- * Preprocessor  -- | Parse the definition of an object-like or function macro.-parseDefinition :: [Token] -> Maybe (String, Macro)+parseDefinition :: [TOKEN] -> Maybe (String, Macro) parseDefinition toks =   case dropWhile (not . isImportant) toks of-    (Important name:Important "(":rst) -> +    (Important name:Important "(":rst) ->       let params = takeWhile (/= ")") $ filter (/= ",") (importants rst)           body = trimUnimportant . tail $ dropWhile (/= Important ")") toks           macro = Function (length params) (functionMacro params body)@@ -316,192 +287,158 @@                   str@(_:t)                     | all (not . isImportant) str -> [Important ""]                     | otherwise -> trimUnimportant t-      in Just (name, Object rhs)+      in Just (copy name, Object (map (fmap copy) rhs))     _ -> Nothing  -- | Returns everything up to the next newline. The newline character -- itself is consumed.-takeLine :: (Monad m, HasError m, HasHppState m) => Parser m Token [Token]-takeLine = do ln <- takingWhile (not . newLine)+takeLine :: (Monad m, HasError m, HasHppState m) => Parser m [TOKEN] [TOKEN]+takeLine = (onElements $ do+              ln <- takingWhile (not . newLine)               eat <- awaitJust "takeLine" -- Eat the newline character               case eat of                 Other "\n" -> return ()                 wat -> error $ "Expected newline: "++show wat++" after "++show ln-              ln <$ incLine--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---- * Nano-lens--type Lens s a = forall f. Functor f => (a -> f a) -> s -> f s--setL :: Lens s a -> a -> s -> s-setL l x = runIdentity . l (const $ Identity x)--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+              return ln)+           <* (lineNum %= (+1)) -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+dropLine :: (Monad m, HasError m, HasHppState m) => Parser m [TOKEN] ()+dropLine = do onElements $ do+                droppingWhile (not . newLine)+                eat <- awaitJust "dropLine" -- Eat the newline character+                case eat of+                  Other "\n" -> return ()+                  wat -> error $ "Expected dropped newline: "++show wat+              lineNum %= (+1)  -- * State Zooming -expandLineP :: (HppCaps m, Monad m) => Parser m Token [Token]+expandLineP :: (Monad m, HasHppState m, HasEnv m, HasError m)+            => Parser m [TOKEN] [TOKEN] expandLineP =-  do st <- liftP getState+  do st <- 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+hppReadFile :: Monad m => Int -> FilePath -> HppT src m src+hppReadFile n file = HppT (pure (FreeF (ReadFile n file return))) -incLine :: (Monad m, HasHppState m) => Parser m i ()-incLine = over' lineNum (+1)+hppReadNext :: Monad m => Int -> FilePath -> HppT src m src+hppReadNext n file = HppT (pure (FreeF (ReadNext n file return)))  -- * Directive Processing  -- | Handle preprocessor directives (commands prefixed with an octothorpe).-directive :: forall m. (Monad m, HppCaps m) => 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] ())))+directive :: forall m. (Monad m, HppCaps m)+          => HppT [String] (Parser m [TOKEN]) Bool+directive = lift (onElements (awaitJust "directive")) >>= aux+  where aux :: TOKEN -> HppT [String] (Parser m [TOKEN]) Bool         aux (Important cmd) = case cmd of-          "pragma" -> 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+          "pragma" -> True <$ lift dropLine -- Ignored+          "define" -> True <$+                      (lift $ fmap parseDefinition takeLine >>= \case+                        Nothing -> use lineNum >>=+                                   throwError . BadMacroDefinition+                        Just def -> env %= insertPair def)+          "undef" -> do name <- lift . onElements $ do+                          droppingWhile (not . isImportant)+                          Important name <- awaitJust "undef"+                          return name+                        lift dropLine+                        env %= deleteKey name+                        return True+          "include" -> True <$ includeAux hppReadFile+          "include_next" -> True <$ includeAux hppReadNext+          "line" -> do lift (onElements droppingSpaces)+                       toks <- lift (init <$> expandLineP)                        case toks of-                         Important n:optFile ->+                         Important (toChars -> n):optFile ->                            case readMaybe n of-                             Nothing -> getL' lineNum >>=+                             Nothing -> use 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))+                                 let fn = toChars . unquote . detokenize+                                        . dropWhile (not . isImportant)+                                        $ optFile+                                 config %= (\cfg -> cfg { curFileNameF = pure fn })+                               lineNum .= ln'+                               return True+                         _ -> use lineNum >>=+                              throwError+                              . flip BadLineArgument (toChars (detokenize toks))+          "ifdef" ->+            do toks <- lift (onElements droppingSpaces >> takeLine)+               ln <- use lineNum+               case takeWhile isImportant toks of+                 [Important t] ->+                   lookupMacro t >>= \case+                     Nothing ->+                       lift (dropBranchLine ln >>= replace . fst)+                     Just _ ->+                       lift (onInputSegment (takeBranchFun ln)) -- (takeBranch ln >>= precede)+                 _ -> throwError . UnknownCommand ln $+                      "ifdef "++ toChars (detokenize toks)+               return True+          "ifndef" ->+            do toks <- lift (onElements droppingSpaces >> takeLine)+               ln <- use lineNum+               case takeWhile isImportant toks of+                 [Important t] ->+                   lookupMacro t >>= \case+                      Nothing -> lift (onInputSegment (takeBranchFun ln)) -- takeBranch ln >>= precede)+                      Just _ -> lift (dropBranchLine ln >>= replace . fst)+                 _ -> throwError . UnknownCommand ln $+                      "ifndef "++ toChars (detokenize toks)+               return True+          "else" -> True <$ lift dropLine+          "if" -> True <$ ifAux+          "elif" -> True <$ ifAux+          "endif" -> True <$ lift dropLine+          "error" -> do toks <- lift (onElements droppingSpaces >> takeLine)+                        ln <- subtract 1 <$> use lineNum+                        curFile <- curFileName <$> use config+                        let tokStr = toChars (detokenize toks)+                        throwError $ UserError ln (tokStr++" ("++curFile++")")+          "warning" -> True <$ lift dropLine -- warnings not yet supported+          -- t -> do toks <- lift takeLine+          --         ln <- subtract 1 <$> use lineNum+          --         throwError $ UnknownCommand ln (detokenize (Important t:toks))+          _ -> return False -- Ignore unknown command         aux _ = error "Impossible unimportant directive"+        includeAux :: (LineNum -> FilePath -> HppT src (Parser m [TOKEN]) [String])+                   -> HppT src (Parser m [TOKEN]) ()         includeAux readFun =-          do fileName <- 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+          do fileName <- lift (toChars . detokenize . trimUnimportant . init+                               <$> expandLineP)+             ln <- use lineNum+             src <- prepareInput <*> readFun ln fileName+             lineNum .= ln+1+             lift (streamNewFile (unquote fileName) src)+        {- SPECIALIZE includeAux ::+            (LineNum -> FilePath -> HppT [String] (Parser (StateT HppState (ExceptT Error IO)) [TOKEN]) [String])+            -> HppT [String] (Parser (StateT HppState (ExceptT Error IO)) [TOKEN]) () #-}+        ifAux =+          do toks <- lift (onElements droppingSpaces >> takeLine)+             e <- use env+             ln <- use lineNum+             lineNum .= ln - 1 -- takeLine incremented the line count+             ex <- lift (lift (evalParse expandLineP [squashDefines e toks]))+             let res = evalExpr <$> parseExpr (map (fmap toChars) ex)+             lineNum .= ln+             if maybe False (/= 0) res+               then lift (onInputSegment (takeBranchFun ln)) -- (takeBranch ln >>= precede)+               else lift (dropBranchLine ln >>= replace . fst) +{-# SPECIALIZE directive ::+    HppT [String] (Parser (StateT HppState (ExceptT Error IO)) [TOKEN]) Bool #-}+ -- | We want to expand macros in expressions that must be evaluated -- for conditionals, but we want to take special care when dealing -- with the meta @defined@ operator of the expression language that is -- a predicate on the evaluation environment.-squashDefines :: Env -> [Token] -> [Token]+squashDefines :: Env -> [TOKEN] -> [TOKEN] squashDefines _ [] = [] squashDefines env' (Important "defined" : ts) = go ts   where go (t@(Other _) : ts') = t : go ts'@@ -509,182 +446,188 @@         go (Important t : ts') =           case lookupKey t env' of             Nothing -> Important "0" : squashDefines env' ts'-            Just (_,env'') -> Important "1" : squashDefines env'' ts'+            -- Just (_,env'') -> Important "1" : squashDefines env'' ts'+            Just _ -> Important "1" : squashDefines env' ts'         go [] = [] squashDefines env' (t : ts) = t : squashDefines env' ts -getCmd :: [Token] -> Maybe String+getCmd :: [TOKEN] -> Maybe String getCmd = aux . dropWhile notImportant   where aux (Important "#" : ts) = case dropWhile notImportant ts of                                      (Important cmd:_) -> Just cmd                                      _ -> Nothing         aux _ = Nothing -droppingSpaces :: Monad m => Parser m Token ()+droppingSpaces ::(Monad m) => ParserT m src 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))+dropBranchFun :: [[TOKEN]] -> (Int, [[TOKEN]])+dropBranchFun = go (1::Int) 0+  where go _ !n [] = (n,[])+        go !nesting !n (ln:lns) =+          case getCmd ln of+            Just cmd+              | cmd == "endif" -> if nesting == 1+                                  then (n, ln:lns)+                                  else go (nesting-1) (n+1) lns+              | cmd `elem` ["if","ifdef","ifndef"] ->+                go (nesting+1) (n+1) lns+              | cmd `elem` ["else","elif"] -> if nesting == 1+                                              then (n, ln : lns)+                                              else go nesting (n+1) lns+            _ -> go nesting (n+1) lns  -- | Take everything up to the end of this branch, drop all remaining -- branches (if any).-takeBranch :: 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))+takeBranchFun :: LineNum -> [[TOKEN]] -> [[TOKEN]]+takeBranchFun = go (1::Int)+  where go _ _ [] = [] -- error: unterminated conditional+        go 0 !n lns = yieldLineNum n : lns+        go !nesting !n (ln:lns) =+          case getCmd ln of+            Just cmd+              | cmd `elem` ["if","ifdef","ifndef"] ->+                ln : go (nesting+1) (n+1) lns+              | cmd == "endif" -> ln : go (nesting - 1) (n + 1) lns+              | nesting == 1 && cmd `elem` ["else","elif"] ->+                let (numSkipped, lns') = dropBranchFun lns+                in go 1 (n+1+numSkipped) lns'+            _ -> ln : go nesting (n+1) lns -yieldLineNum :: 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))+yieldLineNum :: LineNum -> [TOKEN]+yieldLineNum !ln = [Important ("#line " <> fromString (show ln)), Other "\n"] -dropBranchLine :: Monad m => LineNum -> Streamer m [Token] [Token] ()-dropBranchLine !ln = dropBranch $ \el numSkipped ->-                       yieldLineNum (ln + numSkipped) (traverse_ yield el)+dropBranchLine :: (HasError m, Monad m)+               => LineNum -> Parser m [TOKEN] ([TOKEN], LineNum)+dropBranchLine !ln = do (el, numSkipped) <- dropBranch+                        let ln' = ln + numSkipped+                        return (yieldLineNum ln' ++ fromMaybe [] el, ln')  -- | Skip to the end of a conditional branch. Returns the 'Just' the -- token that ends this branch if it is an @else@ or @elif@, or -- 'Nothing' otherwise, and the number of lines skipped.-dropBranch :: 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-              | cmd == "endif" -> if nesting == 1-                                  then k Nothing (n+1)-                                  else go (nesting-1) (n+1)-              | cmd `elem` ["if","ifdef","ifndef"] ->-                go (nesting+1) (n+1)-              | cmd `elem` ["else", "elif"] -> if nesting == 1-                                               then k (Just ln) (n+1)-                                               else go nesting (n+1)-            _ -> go nesting (n+1)+dropBranch :: (HasError m, Monad m) => Parser m [TOKEN] (Maybe [TOKEN], Int)+dropBranch = go (1::Int) 0+  where go !nesting !n =+          do ln <- awaitJust "dropBranch"+             case getCmd ln of+               Just cmd+                 | cmd == "endif" -> if nesting == 1+                                     then return (Nothing, n+1)+                                     else go (nesting-1) (n+1)+                 | cmd `elem` ["if","ifdef","ifndef"] ->+                   go (nesting+1) (n+1)+                 | cmd `elem` ["else", "elif"] -> if nesting == 1+                                                  then return (Just ln, n+1)+                                                  else go nesting (n+1)+               _ -> go nesting (n+1)  -- | Expands an input line producing a stream of output lines.-macroExpansion :: (HppCaps m, Monad m) => Parser m [Token] (Maybe [Token])+macroExpansion :: (Monad m, HppCaps m)+               => HppT [String] (Parser m [TOKEN]) (Maybe [TOKEN]) macroExpansion = do-  awaitP >>= \case+  lift await >>= \case     Nothing -> return Nothing     Just ln ->+      -- when (not (all isSpace (detokenize ln)))+      --      (trace ("macro expand: "++detokenize ln) (return ())) >>       case dropWhile notImportant ln of-        [] -> incLine >> return (Just ln)-        Important "#":rst -> do replace (dropWhile notImportant rst)-                                directive-                                macroExpansion-        _ -> do replace ln-                zoomParseChunks (Just <$> expandLineP) <* incLine+        [] -> Just ln <$ (lineNum %= (+1))+        Important "#":rst -> do lift (replace (dropWhile notImportant rst))+                                processed <- directive+                                if processed+                                then macroExpansion+                                else Just ln <$ lift takeLine+        _ -> lift (replace ln >> (Just <$> expandLineP)) <* (lineNum %= (+1))  -- | The dynamic capabilities offered by HPP-type HppCaps t = (HasError t, HasHppState t, HasHppFileIO t, HasEnv t)+type HppCaps t = (HasError t, HasHppState t, HasEnv t)  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')+               => HppT t (Parser m i) (Maybe t) -> HppT t (Parser m i) ()+parseStreamHpp m = go+  where go = m >>= \case+          Nothing -> return ()+          Just o -> writeOutput o >> go  -- * HPP configurations  -- | Standard CPP settings for processing C files.-normalCPP :: Monad m => Streamer m String [Token] ()-normalCPP = mapping trigraphReplacement-          ~> mapping dropOneLineBlockComments-          ~> removeMultilineComments 1-          ~> mapping dropLineComments-          ~> lineSplicing-          ~> mapping ((++[Other "\n"]) . tokenize)+normalCPP :: [String] -> [[TOKEN]]+normalCPP = map ((++ [Other "\n"]) . tokenize)+          . lineSplicing+          -- . map dropLineComments+          . removeMultilineComments 1+          . map (dropOneLineBlockComments . trigraphReplacement)+{-# INLINABLE normalCPP #-} --- | 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)+-- | For Haskell we do not want trigraph replacement.+haskellCPP :: [String] -> [[TOKEN]]+haskellCPP = map ((++[Other "\n"]) . tokenize)+           . lineSplicing+           . commentRemoval+{-# INLINABLE haskellCPP #-}  -- | If we don't have a predefined processor, we build one based on a -- 'Config' value.-genericConfig :: 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+genericConfig :: Config -> [String] -> [[TOKEN]]+genericConfig cfg = map ((++ [Other "\n"]) . tokenize)+                  . (if spliceLongLines cfg then lineSplicing else id)+                  . (if eraseCComments cfg then commentRemoval else id)+                  . (if replaceTrigraphs cfg then map trigraphReplacement else id)  -- * Front End -prepareInput :: (Monad m, HppCaps m)-             => Streamer m String [Token] ()-prepareInput = Streamer $+prepareInput :: (Monad m, HppCaps m) => m ([String] -> [[TOKEN]])+prepareInput =   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] () #-}+       _ | eraseCComments cfg && spliceLongLines cfg+           && not (inhibitLinemarkers cfg) -> pure normalCPP+       _ | (eraseCComments cfg && spliceLongLines cfg+            && (not (replaceTrigraphs cfg))) ->+           pure haskellCPP+       _ | otherwise -> pure (genericConfig cfg)  -- | Run a stream of lines through the preprocessor. preprocess :: (Monad m, HppCaps m)-           => Source m String ()-           -> Source m String ()-preprocess src = Streamer $+           => ([String] -> src) -> [String] -> HppT [String] (Parser m [TOKEN]) ()+preprocess _convertOutput src =   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+     prep <- prepareInput+     let prepOutput = if inhibitLinemarkers cfg then aux else pure+     lift (precede (prep src))+     parseStreamHpp (fmap (prepOutput . detokenize) <$> macroExpansion)+  where aux xs | sIsPrefixOf "#line" xs = []+               | otherwise = [xs] --- | 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+-- | General hpp runner against input source file lines; can return an+-- 'Error' value if something goes wrong.+hppIO' :: Config -> Env -> ([String] -> IO ()) -> [String] -> IO (Maybe Error)+hppIO' cfg env' snk src =+  runExceptT'+    (evalStateT+       (evalParse+          ((>>= either (throwError . snd) return)+           (runHpp (liftIO . readLines)+                   (liftIO . snk)+                   (preprocess id src)))+          [])+       initialState) >>= return . either Just (const Nothing)+  where initialState = setL env env' $ emptyHppState cfg+        runExceptT' = runExceptT :: ExceptT Error m a -> m (Either Error a) --- | 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+-- | General hpp runner against input source file lines. Any errors+-- encountered are thrown with 'error'.+hppIO :: Config -> Env -> ([String] -> IO ()) -> [String] -> IO ()+hppIO cfg env' snk = fmap (maybe () (error . show)) . hppIO' cfg env' snk++-- | hpp runner that returns output lines.+hppFileContents :: Config -> Env ->  FilePath -> [String] -> IO (Either Error [String])+hppFileContents cfg env' fileName src = do+  r <- newIORef id+  let snk xs = modifyIORef r (. (xs++))+  hppIO' (cfg {curFileNameF = pure fileName}) env' snk src >>= \case+    Nothing -> Right . ($ []) <$> readIORef r+    Just e -> return (Left e)

@@ -1,14 +1,17 @@-{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE OverloadedStrings, 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 Data.String (fromString) import Hpp import Hpp.Config import Hpp.Env (deleteKey, emptyEnv, insertPair)+import Hpp.StringSig (readLines, putStringy) import Hpp.Tokens import Hpp.Types (Env, Error(..)) import System.Directory (doesFileExist, makeAbsolute)+import System.IO (openFile, IOMode(..), hClose, stdout)  -- | Break a string on an equals sign. For example, the string @x=y@ -- is broken into @[x,"=",y]@.@@ -37,15 +40,15 @@             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+          case parseDefinition (Important (fromString name) : Other " " : tokenize (fromString body)) of             Nothing -> return . Left $ BadMacroDefinition 0             Just def -> go (insertPair def env) acc cfg out rst         go env acc cfg out ("-D":name:rst) =-          case parseDefinition ([Important name, Other " ", Important "1"]) of+          case parseDefinition ([Important (fromString 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 (deleteKey (fromString 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@@ -57,21 +60,27 @@           in go env acc cfg' out rst         go env acc cfg out ("--cpp":rst) =           let cfg' = cfg { spliceLongLinesF = Just True-                         , eraseCCommentsF = Just True }+                         , eraseCCommentsF = Just True+                         , inhibitLinemarkersF = Just False+                         , replaceTrigraphsF = Just True }               defs = concatMap ("-D":)                        [ ["__STDC__"]                          -- __STDC_VERSION__ is only defined in C94 and later-                       , ["__STDC_VERSION__","=","199409L"]-                       , ["_POSIX_C_SOURCE","=","200112L"] ]+                       , ["__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 ("--freplace-trigraphs":rst) =+          go env acc (cfg { replaceTrigraphsF = 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 out ("-traditional":rst) =+          go env acc cfg out rst -- Ignore the "-traditional" flag         go env acc cfg Nothing (file:rst) =           case curFileNameF cfg of             Nothing -> go env acc (cfg { curFileNameF = Just file }) Nothing rst@@ -91,11 +100,16 @@        "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 ()+     (snk, closeSnk) <- case outPath of+                          Nothing -> return (mapM_ (putStringy stdout) , return ())+                          Just f ->+                            do h <- makeAbsolute f >>=+                                    flip openFile WriteMode+                               return (\os -> mapM_ (putStringy h) os+                                      ,hClose h)+     _ <- (readLines fileName)+           >>= hppIO cfg' env snk . (map fromString lns ++)+     -- lns' <- (lines <$> readFile fileName)+     --          >>= hppFileContents cfg env fileName . (lns ++)+     -- snk lns'+     closeSnk

@@ -22,6 +22,7 @@                         , spliceLongLinesF    :: f Bool                         , eraseCCommentsF     :: f Bool                         , inhibitLinemarkersF :: f Bool+                        , replaceTrigraphsF   :: f Bool                         , prepDateF           :: f DateString                         , prepTimeF           :: f TimeString } @@ -35,10 +36,11 @@                       (Just spliceLines)                       (Just comments)                       (Just inhibitLines)+                      (Just trigraphs)                       (Just pdate)                       (Just ptime)) =   Just (Config (pure fileName) (pure paths) (pure spliceLines) (pure comments)-               (pure inhibitLines) (pure pdate) (pure ptime))+               (pure inhibitLines) (pure trigraphs) (pure pdate) (pure ptime)) realizeConfig _ = Nothing  -- | Extract the current file name from a configuration.@@ -61,6 +63,10 @@ inhibitLinemarkers :: Config -> Bool inhibitLinemarkers = runIdentity . inhibitLinemarkersF +-- | Determine if trigraph sequences should be replaced.+replaceTrigraphs :: Config -> Bool+replaceTrigraphs = runIdentity . replaceTrigraphsF+ -- | The date the pre-processor was run on. prepDate :: Config -> DateString prepDate = runIdentity . prepDateF@@ -72,7 +78,7 @@ -- | A default configuration with no current file name set. defaultConfigF :: ConfigF Maybe defaultConfigF = Config Nothing (Just [])-                        (Just False) (Just False) (Just False)+                        (Just True) (Just True) (Just True) (Just False)                         (Just (DateString "??? ?? ????"))                         (Just (TimeString "??:??:??")) 

@@ -1,6 +1,24 @@+{-# LANGUAGE TupleSections #-} -- | A name binding context, or environment. module Hpp.Env where+import Data.ByteString (ByteString)+import qualified Data.Trie as T +emptyEnv :: T.Trie a+emptyEnv = T.empty++insertPair :: (ByteString, a) -> T.Trie a -> T.Trie a+insertPair = uncurry T.insert++deleteKey :: ByteString -> T.Trie a -> T.Trie a+deleteKey = T.delete++-- lookupKey :: L.ByteString -> T.Trie a -> Maybe (a, T.Trie a)+-- lookupKey k t = (,t) <$> T.lookup (L.toStrict k) t+lookupKey :: ByteString -> T.Trie a -> Maybe a+lookupKey = T.lookup++ {- import qualified Data.Map as M @@ -20,7 +38,7 @@ lookupKey k m = fmap (\x -> (x, m)) (M.lookup k m) {-# INLINE lookupKey #-} -}-+{- -- | An empty binding environment. emptyEnv :: [a] emptyEnv = []@@ -48,3 +66,4 @@           | k == x = Just (v, h : acc [] ++ xs)           | otherwise = go (acc . (h:)) xs {-# INLINE lookupKey #-}+-}

@@ -1,25 +1,28 @@-{-# LANGUAGE RankNTypes, ScopedTypeVariables #-}+{-# LANGUAGE LambdaCase, OverloadedStrings, 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.Monad (forM)+import Control.Monad.Trans.Class (lift) import Data.Bool (bool) import Data.Foldable (foldl', traverse_) import Data.List (delete) import Data.Maybe (listToMaybe, mapMaybe)+import Data.Monoid ((<>))+import Data.String (fromString) 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.Env (deleteKey)+import Hpp.Parser (Parser, ParserT, precede, replace, await, onIsomorphism,+                   onElements, droppingWhile, awaitJust, evalParse)+import Hpp.StringSig (stringify, uncons, isEmpty, toChars) import Hpp.Tokens (Token(..), notImportant, isImportant, detokenize)-import Hpp.Types (HasError(..), HasEnv(..), Scan(..), Error(..), Macro(..))+import Hpp.Types (HasError(..), HasEnv(..), Scan(..), Error(..), Macro(..),+                  TOKEN, String, lookupMacro)+import Prelude hiding (String) --- | Extract the 'Token' payload from a 'Scan'.-unscan :: Scan -> Maybe Token+-- | Extract the 'TOKEN' payload from a 'Scan'.+unscan :: Scan -> Maybe TOKEN unscan (Scan t) = Just t unscan (Rescan t) = Just t unscan _ = Nothing@@ -33,35 +36,34 @@ -- | 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)+           => Config -> Int -> Parser m [TOKEN] [TOKEN]+expandLine cfg lineNum =+  mapMaybe unscan <$>+  onElements (onIsomorphism Scan unscan (expandLine' True cfg lineNum)) -expandLine' :: forall m. (HasError m, Monad m, HasEnv m)-            => Bool -> Config -> Int -> Parser m Scan [Scan]+expandLine' :: forall m src. (HasError m, Monad m, HasEnv m)+            => Bool -> Config -> Int -> ParserT m src 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]+  where go :: ([Scan] -> [Scan]) -> [String] -> ParserT m src Scan [Scan]+        go acc mask = await >>= maybe (return $ acc []) aux+          where aux :: Scan -> ParserT m src 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+                                           else precede ts >> go acc mask                   Rescan (Important t) ->-                    do oldEnv <- liftP $+                    do oldEnv <- lift $                                  do env <- getEnv                                     setEnv $ foldl' (flip deleteKey) env mask                                     return env                        ts <- expandMacro cfg lineNum t tok-                       liftP $ setEnv oldEnv+                       lift $ setEnv oldEnv                        if ts == [tok]                        then go (acc . (tok:)) mask-                       else precede (source ts) >> go acc mask+                       else precede ts >> go acc mask                   Scan (Other "\n")                     | oneLine -> return (acc [tok])                     | otherwise -> go (acc . (tok:)) mask@@ -73,10 +75,11 @@ -- | 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 :: (Monad m, HasError m)+         => ParserT m src Scan (Maybe [[Scan]]) appParse = droppingWhile isSpaceScan >> checkApp   where imp = maybe True notImportant . unscan-        checkApp = do tok <- droppingWhile imp >> awaitP+        checkApp = do tok <- droppingWhile imp >> await                       case tok >>= unscan of                         Just (Important "(") -> goApp                         _ -> traverse_ replace tok >> return Nothing@@ -90,7 +93,7 @@ -- | 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 :: (Monad m, HasError m) => ParserT m src Scan [Scan] argParse = go id   where go acc = do tok <- awaitJust "argParse"                     case unscan tok of@@ -104,7 +107,7 @@  -- | 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 :: (Monad m, HasError m) => ParserT m src Scan [Scan] parenthetical = go id (1::Int)   where go acc 0 = return (acc [])         go acc n = do tok <- awaitJust "parenthetical"@@ -115,16 +118,17 @@  argError :: Int -> String -> Int -> [String] -> Error argError lineNum name arity args =-  TooFewArgumentsToMacro lineNum $ name++"<"++show arity++">"++show args+  TooFewArgumentsToMacro lineNum $+  toChars name <> "<" <> show arity <> ">" <> show args  -- | 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])+               -> (forall r'. [String] -> ParserT m src Scan r')+               -> ([Scan] -> ParserT m src Scan [Scan])+               -> ParserT m src Scan (Maybe [Scan]) expandFunction name arity f mkErr expand =   do margs <- appParse      case margs of@@ -133,24 +137,24 @@          | length args /= arity -> mkErr $                                    map (detokenize . mapMaybe unscan) args          | otherwise ->-           do args' <- forM args $ \arg -> liftP (parse expand (source arg))+           do args' <- mapM expand args               let raw = map (detokenize . mapMaybe unscan) args               return . Just $ Mask name : f (zip args' raw) ++ [Unmask name] -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+-- lookupEnv :: (Monad m, HasEnv m)+--           => String -> ParserT m src Scan (Maybe Macro)+-- lookupEnv s = lift $ getEnv >>= traverse aux . lookupKey s+--   where aux (m, env') = setEnv env' >> return m  expandMacro :: (Monad m, HasError m, HasEnv m)-            => Config -> Int -> String -> Scan -> Parser m Scan [Scan]+            => Config -> Int -> String -> Scan -> ParserT m src 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-    _ -> do mm <- lookupEnv name+    "__LINE__" -> simple . fromString $ show lineNum+    "__FILE__" -> simple . stringify . fromString $ curFileName cfg+    "__DATE__" -> simple . stringify . fromString . getDateString $ prepDate cfg+    "__TIME__" -> simple . stringify . fromString . getTimeString $ prepTime cfg+    _ -> do mm <- lift (lookupMacro name)             case mm of               Nothing -> return [tok]               Just m ->@@ -159,22 +163,26 @@                     return $ Mask name : map Rescan (spaced t') ++ [Unmask name]                   Function arity f ->                     let ex = expandLine' False cfg lineNum-                        err = liftP . throwError+                        err = lift . throwError                             . argError lineNum name arity-                    in do mts <- expandFunction name arity f err ex+                    in do mts <- expandFunction name arity f err+                                                (lift . evalParse 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 ++ pos-          where importantChar (Important [c]) = elem c oops+        spaced xs = pre <> pos+          where importantChar (Important t) =+                  case uncons t of+                    Nothing -> False+                    Just (c,t') -> elem c oops && isEmpty t'                 importantChar _ = False                 pre = bool xs (Other " ":xs)$                       (maybe False importantChar $ listToMaybe xs)                 pos = bool [] [Other " "] $                       (maybe False importantChar $ listToMaybe (reverse xs))-                oops = "-+*.><"+                oops = "-+*.><" :: [Char]  -- | Trim whitespace from both ends of a sequence of 'Scan' tokens. trimScan :: [Scan] -> [Scan]

@@ -126,7 +126,7 @@ -- * Lexing  -- | String literals are split by tokenization. Fix them!-fixStringLits :: [Token] -> Maybe [String]+fixStringLits :: [Token String] -> Maybe [String] fixStringLits [] = Just [] fixStringLits (Important h@('"':_):xs) =   let (hs,ys) = break ((== '"') . last . detok) xs@@ -138,9 +138,9 @@ fixStringLits (Other _ : xs) = fixStringLits xs  onFirstImportant :: (String -> String)-                 -> ([Token] -> [Token])-                 -> [Token]-                 -> [Token]+                 -> ([Token String] -> [Token String])+                 -> [Token String]+                 -> [Token String] onFirstImportant f k = go   where go [] = k []         go (Important s : ts') = Important (f s) : k ts'@@ -148,7 +148,7 @@  -- | Re-combine positive and negative unary operators with the tokens -- to which they are attached.-fixUnaryOps :: [Token] -> [Token]+fixUnaryOps :: [Token String] -> [Token String] fixUnaryOps [] = [] fixUnaryOps (t0:ts0) =   case t0 of@@ -164,7 +164,7 @@         go _ (o@(Other _):ts) = o : go False ts  -- | Re-combine multiple-character operators.-fixBinaryOps :: [Token] -> [Token]+fixBinaryOps :: [Token String] -> [Token String] fixBinaryOps [] = [] fixBinaryOps (h@(Important t1) : ts@(Important t2 : ts')) =   case parseBinOp (t1++t2) of@@ -198,7 +198,7 @@ renderUnaryOp Not = "!" renderUnaryOp Defined = "defined " -lexExpr :: [Token] -> Maybe [String]+lexExpr :: [Token String] -> Maybe [String] lexExpr = fixStringLits . fixUnaryOps . fixBinaryOps  -- * Parsing Tokens@@ -367,7 +367,7 @@ rpnToExpr _ _ = Nothing  -- | Try to read an 'Expr' from a sequence of 'Token's.-parseExpr :: [Token] -> Maybe Expr+parseExpr :: [Token String] -> Maybe Expr parseExpr = lexExpr >=> shuntRPN [] [] >=> rpnToExpr []  -- | Pretty-print an 'Expr' to something semantically equivalent to the original@@ -378,7 +378,7 @@ renderExpr (ELit (LitStr e)) = '"':e++"\"" renderExpr (ELit (LitChar c)) = [c] renderExpr (ELit (LitID e)) = e-renderExpr (EBinOp o e1 e2) = concat [ "(", renderExpr e1," ",renderBinOp o +renderExpr (EBinOp o e1 e2) = concat [ "(", renderExpr e1," ",renderBinOp o                                      , " ", renderExpr e2, ")" ] renderExpr (EUnaryOp o e1) = renderUnaryOp o ++ renderExpr e1 @@ -423,6 +423,6 @@         go (EUnaryOp BitNot e2) = cppComplement $ go e2         go (EUnaryOp Not e2) = int . fromEnum $ go e2 == 0         go (EUnaryOp Defined e2) =-          case e2 of +          case e2 of             ELit (LitInt 1) -> 1             _ -> 0

@@ -1,110 +1,115 @@-{-# LANGUAGE BangPatterns, LambdaCase, RankNTypes #-}+{-# LANGUAGE LambdaCase, Rank2Types, TupleSections, ScopedTypeVariables #-} -- | 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(..))+module Hpp.Parser (Parser, ParserT, parse, evalParse, await, awaitJust, replace,+                   droppingWhile, precede, takingWhile, onChunks, onElements,+                   onInputSegment, insertInputSegment, onIsomorphism,+                   runParser) where+import Control.Arrow (second, (***)) 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 Hpp.Types (HasError(..), Error(UserError)) import Control.Monad.Trans.Class (lift)-import Control.Monad.IO.Class (MonadIO, liftIO)+import Data.List.NonEmpty (NonEmpty(..))+import Data.Maybe (mapMaybe)+import Data.Monoid ((<>))  -- * Parsers -type ParserR m r i = StateT (Source m i r) m+type RopeM m a = [Either (m ()) a] --- | 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 }+-- | A 'Parser' is a bit of state carrying a source of input.+type ParserT m src i = StateT (Headspring m src i, src) m --- | 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 #-}+type Parser m i = ParserT m (RopeM m [i]) i -instance Functor m => Functor (Parser m i) where-  fmap f (Parser p) = Parser (fmap f p)-  {-# INLINE fmap #-}+data Headspring m src i =+  Headspring { hsAwait :: src -> m (Maybe (i, src))+             , hsPrecede :: [i] -> src -> src } -instance Monad m => Applicative (Parser m i) where-  pure x = Parser (pure x)-  {-# INLINE pure #-}-  Parser f <*> Parser x = Parser (f <*> x)-  {-# INLINE (<*>) #-}+-- | Pop the head non-effect element from a list.+unconsM :: Applicative m => RopeM m a -> m (Maybe (a, RopeM m a))+unconsM [] = pure Nothing+unconsM (Left m : ms) = m *> unconsM ms+unconsM (Right x : ms) = pure (Just (x, ms)) -instance Monad m => Monad (Parser m i) where-  return = pure-  {-# INLINE return #-}-  Parser ma >>= fb = Parser $ ma >>= runParser . fb-  {-# INLINE (>>=) #-}+-- | Pop the first non-null, non-effect element from a list.+unconsMNonEmpty :: Monad m => RopeM m [a] -> m (Maybe (NonEmpty a, RopeM m [a]))+unconsMNonEmpty r = unconsM r >>= \case+  Nothing -> pure Nothing+  Just ([], rst) -> unconsMNonEmpty rst+  Just (x:xs, rst) -> return (Just (x :| xs, rst)) -instance MonadPlus m => Alternative (Parser m i) where-  empty = Parser empty-  {-# INLINE empty #-}-  Parser a <|> Parser b = Parser (a <|> b)-  {-# INLINE (<|>) #-}+unconsSpring :: Monad m => Headspring m (RopeM m [i]) i+unconsSpring = Headspring aw ropePrecede+  where aw r = unconsMNonEmpty r >>= \case+          Nothing -> return Nothing+          Just (x :| xs, r') -> return (Just (x, Right xs : r')) -instance (Monad m, HasError m) => HasError (Parser m i) where-  throwError = liftP . throwError-  {-# INLINE throwError #-}+flattenSpring :: Monad m => Headspring m  (RopeM m [[i]]) i+flattenSpring = Headspring aw pr+  where aw r = unconsMNonEmpty r >>= \case+          Nothing -> return Nothing+          Just ([] :| ys, r') -> aw (Right ys : r')+          Just ((x:xs) :| ys, r') -> return (Just (x, Right (xs:ys) : r'))+        pr xs [] = [Right [xs]]+        pr xs (Right (ys:zs) : ms) = Right ((xs++ys) : zs) : ms+        pr xs (Right [] : ms) = Right [xs] : ms+        pr xs ms@(Left _ : _) = Right [xs] : ms -instance (Monad m, HasHppState m) => HasHppState (Parser m i) where-  getState = liftP getState-  setState = liftP . setState+chunkSpring :: (Monoid src, Applicative m) => Headspring m (RopeM m src) src+chunkSpring = Headspring unconsM pr+  where pr xs [] = [Right (mconcat xs)]+        pr xs (Right ys : ms) = Right (mconcat xs <> ys) : ms+        pr xs ms@(Left _ : _) = Right (mconcat xs) : ms -instance MonadIO m => MonadIO (Parser m i) where-  liftIO = liftP . liftIO+await :: Monad m => ParserT m src i (Maybe i)+await = do (hs, st) <- get+           lift (hsAwait hs st) >>= \case+             Nothing -> return Nothing+             Just (x,st') -> Just x <$ put (hs,st')+{-# INLINE await #-} --- * Operations on Parsers          +-- | Push a value back into a parser's source.+replace :: (Monad m) => i -> ParserT m src i ()+replace = precede . pure --- | Lift a monadic action into a Parser.-liftP :: Monad m => m o -> Parser m i o-liftP m = Parser (lift m)-{-# INLINE liftP #-}+ropePrecede :: [i] -> RopeM m [i] -> RopeM m [i]+ropePrecede xs [] = [Right xs]+ropePrecede xs ms@(Left _ : _) = Right xs : ms+ropePrecede xs (Right ys : ms) = Right (xs++ys) : ms --- | @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 #-}+-- | Push a stream of values back into a parser's source.+precede :: Monad m => [i] -> ParserT m src i ()+precede xs = do (hs,st) <- get+                put (hs, hsPrecede hs xs st)+{-# INLINE precede #-} --- | 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 #-}+-- | Run a 'Parser' with a given input stream.+parse :: Monad m => Parser m i o -> [i] -> m (o, RopeM m [i])+parse m xs = second snd <$> runStateT m (unconsSpring, [Right xs])+{-# INLINE parse #-} +runParser :: Monad m => Parser m i o -> RopeM m [i] -> m (o, RopeM m [i])+runParser m xs = second snd <$> runStateT m (unconsSpring, xs)++evalParse :: Monad m => Parser m i o -> [i] -> m o+evalParse m xs = evalStateT m (unconsSpring, [Right xs])++-- * Operations on Parsers+ -- | '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+awaitJust :: (Monad m, HasError m) => String -> ParserT m src i i+awaitJust s = await >>= maybe (lift $ 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 #-}+{-# INLINE awaitJust #-}  -- | 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 :: (Monad m) => (i -> Bool) -> ParserT m src i () droppingWhile p = go-  where go = awaitP >>= \case+  where go = await >>= \case                Nothing -> return ()                Just x -> if p x then go else replace x {-# INLINE droppingWhile #-}@@ -112,42 +117,52 @@ -- | 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 :: (Monad m) => (i -> Bool) -> ParserT m src i [i] takingWhile p = go id-  where go acc = awaitP >>= \case+  where go acc = await >>= \case                    Nothing -> return (acc [])                    Just x                      | p x -> go (acc . (x:))                      | otherwise -> replace x >> return (acc []) {-# INLINE takingWhile #-} --- * Zooming+insertInputSegment :: Monad m => src -> m () -> ParserT m (RopeM m src) i ()+insertInputSegment xs k = modify' (second ([Right xs, Left k]++)) --- | 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 #-}+onInputSegment :: Monad m => (src -> src) -> ParserT m (RopeM m src) i ()+onInputSegment f = do (hs,st) <- get+                      case st of+                        [] -> return ()+                        (Right xs : ys) -> put (hs, Right (f xs) : ys)+                        (Left m : xs) -> lift m >> put (hs,xs) >> onInputSegment f+{-# INLINABLE onInputSegment #-} --- | 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 #-}+-- * Parser Transformations +onChunks :: Monad m => ParserT m (RopeM m [i]) [i] r -> Parser m i r+onChunks m = do (hs,st) <- get+                (r, (_,st')) <- lift (runStateT m (chunkSpring, st))+                r <$ put (hs,st')++onElements :: Monad m => ParserT m (RopeM m [[i]]) i r -> Parser m [i] r+onElements m = do (hs,st) <- get+                  (r, (_,st')) <- lift (runStateT m (flattenSpring, st))+                  let onHead _ [] = []+                      onHead f (x:xs) = f x : xs+                  r <$ put (hs, onHead (fmap (dropWhile null)) st')+{-# INLINE onElements #-}++onIsomorphism :: forall m a b src r. Monad m+              => (a -> b) -> (b -> Maybe a)+              -> ParserT m ([b],src) b r+              -> ParserT m src a r+onIsomorphism fwd bwd m =+  do (hs,st) <- get+     let aw :: ([b],src) -> m (Maybe (b, ([b], src)))+         aw ([], src) = fmap (fmap (fwd *** ([],))) (hsAwait hs src)+         aw ((b:bs), src) = return (Just (b, (bs,src)))+         pr xs (bs,src) = (xs++bs, src)+         mappedSpring = Headspring aw pr+     (r, (_, (bs, st'))) <- lift (runStateT m (mappedSpring, ([], st)))+     r <$ put (hs, hsPrecede hs (mapMaybe bwd bs) st')+{-# INLINE onIsomorphism #-}

@@ -1,70 +0,0 @@-{-# 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_)

@@ -1,356 +0,0 @@-{-# 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)-  #-}

@@ -2,7 +2,7 @@ -- | HELPERS for working with 'String's module Hpp.String (stringify, unquote, trimSpaces, breakOn, cons) where import Data.Char (isSpace)-import Data.List (isPrefixOf)+import Data.List (isPrefixOf, find)  -- | Stringification puts double quotes around a string and -- backslashes before existing double quote characters and backslash@@ -37,16 +37,19 @@  -- | 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'+-- @breakOn needles haystack@ finds the first instance of an element+-- of @needles@ in @haystack@. The first component of the result is+-- the needle tag, the second component is the prefix of @haystack@+-- before the matched needle, the third component is the remainder of+-- the @haystack@ /after/ the needle..+breakOn :: [(String,t)] -> String -> Maybe (t, String, String)+breakOn needles haystack = go 0 haystack+  where go _ [] = Nothing+        go !i xs@(_:xs') =+          case find (flip isPrefixOf xs . fst) needles of+            Nothing -> go (i+1) xs'+            Just (n,tag) -> Just (tag, take i haystack, drop (length n) xs)+{-# INLINE breakOn #-}  -- | Used to make switching to the @text@ package easier. cons :: a -> [a] -> [a]

@@ -0,0 +1,213 @@+{-# LANGUAGE BangPatterns, CPP, FlexibleInstances, OverloadedStrings,+             PatternSynonyms, TypeSynonymInstances, ViewPatterns #-}+module Hpp.StringSig where+import Data.Char+import qualified Data.List as L+import Data.Maybe (isJust)+import Data.String (IsString)+import qualified Hpp.String as S+import qualified Data.ByteString.Char8 as B+import qualified Data.ByteString.Lazy.Char8 as BL+import System.IO (Handle, hPutStr)++data CharOrSub s = CharMatch !s !s | SubMatch !s !s | NoMatch++class (IsString s, Monoid s) => Stringy s where+  -- | Stringification puts double quotes around a string and+  -- backslashes before existing double quote characters and backslash+  -- characters.+  stringify :: s -> s++  -- | Remove double quote characters from the ends of a string.+  unquote :: s -> s++  -- | Trim trailing spaces from a 'String'+  trimSpaces :: s -> s++  -- | Similar to the function of the same name in the @text@ package.+  --+  -- @breakOn needles haystack@ finds the first instance of an element+  -- of @needles@ in @haystack@. The first component of the result is+  -- the needle tag, the second component is the prefix of @haystack@+  -- before the matched needle, the third component is the remainder of+  -- the @haystack@ /after/ the needle..+  breakOn :: [(s,t)] -> s -> Maybe (t, s, s)++  -- | A special case of 'breakOn' in which we are looking for either+  -- a special character or a particular substring.+  breakCharOrSub :: Char -> s -> s -> CharOrSub s+  cons :: Char -> s -> s+  uncons :: s -> Maybe (Char, s)+  snoc :: s -> Char -> s+  unsnoc :: s -> Maybe (s, Char)+  sdrop :: Int -> s -> s+  sbreak :: (Char -> Maybe t) -> s -> Maybe (t,s,s)+  sall :: (Char -> Bool) -> s -> Bool+  sIsPrefixOf :: s -> s -> Bool+  isEmpty :: s -> Bool+  readLines :: FilePath -> IO [s]+  putStringy :: Handle -> s -> IO ()+  toChars :: s -> [Char]+  -- | An opportunity to copy a string to its own storage to help with GC+  copy :: s -> s++instance Stringy String where+  stringify = S.stringify+  {-# INLINE stringify #-}+  unquote = S.unquote+  {-# INLINE unquote  #-}+  trimSpaces = S.trimSpaces+  {-# INLINE trimSpaces #-}+  breakOn = S.breakOn+  {-# INLINE breakOn #-}+  breakCharOrSub c sub str =+    case S.breakOn [([c], True), (sub, False)] str of+      Nothing -> NoMatch+      Just (True, pre, pos) -> CharMatch pre pos+      Just (False, pre, pos) -> SubMatch pre pos+  {-# INLINE breakCharOrSub #-}+  cons = S.cons+  {-# INLINE cons #-}+  uncons = L.uncons+  {-# INLINE uncons #-}+  snoc s c = s ++ [c]+  {-# INLINE snoc #-}+  unsnoc [] = Nothing+  unsnoc s = Just (init s, last s)+  {-# INLINE unsnoc #-}+  sdrop = drop+  {-# INLINE sdrop #-}+  sbreak _ [] =  Nothing+  sbreak p (x:xs') =+    case p x of+      Nothing -> let res = sbreak p xs' in fmap (_2 (x:)) res+      Just t -> Just (t, [], xs')+    where _2 f (a,b,c) = (a, f b, c)+  {-# INLINE sbreak #-}+  sall = all+  {-# INLINE sall #-}+  sIsPrefixOf = L.isPrefixOf+  isEmpty = null+  {-# INLINE isEmpty #-}+  readLines = fmap lines . readFile+  putStringy = hPutStr+  toChars = id+  copy = id++instance Stringy B.ByteString where+  stringify s = B.cons '"' (B.snoc (B.concatMap aux (strip s)) '"')+    where aux '\\' = "\\\\"+          aux '"' = "\\\""+          aux c = B.singleton c+          strip = trimSpaces . B.dropWhile isSpace+  {-# INLINE stringify #-}+  unquote s = let s' = case B.uncons s of+                         Nothing -> s+                         Just (c, rst) -> if c == '"' then rst else s+              in case B.unsnoc s' of+                   Nothing -> s'+                   Just (ini, c) -> if c == '"' then ini else s'+  {-# INLINE unquote #-}+  trimSpaces s = let go !i = if isSpace (B.index s i)+                             then go (i-1)+                             else B.length s - i - 1+                 in B.drop (go (B.length s - 1)) s+  {-# INLINE trimSpaces #-}+  breakOn [!(!n1,!t1)] haystack =+    case B.breakSubstring n1 haystack of+      (pre,pos) | B.null pos -> Nothing+                | otherwise -> Just (t1, pre, B.drop (B.length n1) pos)++  breakOn [!(!n1, !t1), !(n2, !t2)] haystack = go2 0 haystack+    where go2 !i !h+            | B.null h = Nothing+            | B.isPrefixOf n1 h = let !h' = B.drop (B.length n1) h+                                      !pre = B.take i haystack+                                  in Just (t1, pre, h')+            | B.isPrefixOf n2 h = let !h' = B.drop (B.length n2) h+                                      !pre = B.take i haystack+                                  in Just (t2, pre, h')+            | otherwise = go2 (i+1) (B.tail h)+  breakOn [!(!n1, !t1), !(n2, !t2), !(!n3, !t3)] haystack = go3 0 haystack+    where go3 !i !h+            | B.null h = Nothing+            | B.isPrefixOf n1 h = let h' = B.drop (B.length n1) h+                                  in Just (t1, B.take i haystack, h')+            | B.isPrefixOf n2 h = let h' = B.drop (B.length n2) h+                                  in Just (t2, B.take i haystack, h')+            | B.isPrefixOf n3 h = let h' = B.drop (B.length n3) h+                                  in Just (t3, B.take i haystack, h')+            | otherwise = go3 (i+1) (B.tail h)+  breakOn needles haystack = go 0 haystack+    where go !i !h+            | B.null h = Nothing+            | otherwise =+              case L.find (flip B.isPrefixOf h . fst) needles of+                Nothing -> go (i+1) (B.tail h)+                Just (n,tag) -> let h' = B.drop (B.length n ) h+                                in Just (tag, B.take i haystack, h')+  {-# INLINE breakOn #-}+  breakCharOrSub c sub str =+    case B.elemIndex c str of+      Nothing -> case B.breakSubstring sub str of+                   (pre,pos)+                     | B.null pos -> NoMatch+                     | otherwise -> SubMatch pre (B.drop (B.length sub) pos)+      Just i ->+        case B.breakSubstring sub str of+          (pre,pos)+            | B.null pos -> CharMatch (B.take i str) (B.drop (i+1) str)+            | B.length pre < i -> SubMatch pre (B.drop (B.length sub) pos)+            | otherwise -> CharMatch (B.take i str) (B.drop (i+1) str)++  {-# INLINE breakCharOrSub #-}+  cons = B.cons+  uncons = B.uncons+  snoc = B.snoc+  unsnoc = B.unsnoc+  sdrop = B.drop . fromIntegral+  sbreak f s = case B.break (isJust . f) s of+                 (h,t) -> case B.uncons t of+                            Nothing -> Nothing+                            Just (c,t') -> fmap (\r -> (r,h,t')) (f c)+  {-# INLINE sbreak #-}+  sall = B.all+  sIsPrefixOf = B.isPrefixOf+  isEmpty = B.null+  readLines = fmap (map BL.toStrict . BL.lines) . BL.readFile+  {-# INLINE readLines #-}+  putStringy = B.hPutStr+  toChars = B.unpack+  copy = B.copy++boolJust :: Bool -> Maybe ()+boolJust True = Just ()+boolJust False = Nothing+{-# INLINE boolJust #-}++predicateJust :: (a -> Bool) -> a -> Maybe a+predicateJust f c = if f c then Just c else Nothing+{-# INLINE predicateJust #-}++sdropWhile :: Stringy s => (Char -> Bool) -> s -> s+sdropWhile f s = case sbreak (boolJust . f) s of+                   Nothing -> s+                   Just (_, _, s') -> s'+{-# INLINE sdropWhile #-}++#if __GLASGOW_HASKELL__ >= 800+pattern (:.) :: Stringy s => Char -> s -> s+#else+pattern (:.) :: () => Stringy s => Char -> s -> s+#endif+pattern x :. xs <- (uncons -> Just (x,xs)) where+  x:.xs = cons x xs+infixr 5 :.++#if __GLASGOW_HASKELL__ >= 800+pattern Nil :: Stringy s => s+#else+pattern Nil :: () => Stringy s => s+#endif+pattern Nil <- (isEmpty -> True) where+  Nil = mempty

@@ -1,86 +1,150 @@+{-# LANGUAGE BangPatterns, OverloadedStrings, ViewPatterns #-} -- | Tokenization breaks a 'String' into pieces of whitespace, -- constants, symbols, and identifiers.-module Hpp.Tokens where-import Data.Char (isAlphaNum, isDigit, isSpace)+module Hpp.Tokens (Token(..), detok, isImportant, notImportant, importants,+                   trimUnimportant, detokenize, tokenize, newLine,+                   skipLiteral) where+import Control.Arrow (first, second)+import Data.Char (isAlphaNum, isDigit, isSpace, isOctDigit, isHexDigit, digitToInt)+import Data.Foldable (foldl')+import Data.Monoid ((<>))+import Data.String (IsString, fromString)+import Hpp.StringSig  -- | Tokenization is 'words' except the white space is tagged rather -- than discarded.-data Token = Important String-           -- ^ Identifiers, symbols, and constants-           | Other String-           -- ^ White space, etc.-             deriving (Eq,Ord,Show)+data Token s = Important s+             -- ^ Identifiers, symbols, and constants+             | Other s+             -- ^ White space, etc.+               deriving (Eq,Ord,Show) +instance Functor Token where+  fmap f (Important s) = Important (f s)+  fmap f (Other s) = Other (f s)+  {-# INLINE fmap #-}+ -- | Extract the contents of a 'Token'.-detok :: Token -> String+detok :: Token s -> s detok (Important s) = s detok (Other s) = s {-# INLINE detok #-}  -- | 'True' if the given 'Token' is 'Important'; 'False' otherwise.-isImportant :: Token -> Bool+isImportant :: Token s -> Bool isImportant (Important _) = True isImportant _ = False  -- | 'True' if the given 'Token' is /not/ 'Important'; 'False' -- otherwise.-notImportant :: Token -> Bool+notImportant :: Token s -> Bool notImportant (Other _) = True notImportant _ = False  -- | Return the contents of only 'Important' (non-space) tokens.-importants :: [Token] -> [String]+importants :: [Token s] -> [s] importants = map detok . filter isImportant  -- | Trim 'Other' 'Token's from both ends of a list of 'Token's.-trimUnimportant :: [Token] -> [Token]+trimUnimportant :: [Token s] -> [Token s] 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 :: (Eq s, IsString s) => Token s -> Bool+newLine (Other s) = s == "\n" newLine _ = False +maybeImp :: Stringy s => s -> [Token s]+maybeImp s = if isEmpty s then [] else [Important s]++digitsFromBase :: Stringy s => Int -> s -> s+digitsFromBase base = fromString . show . foldl' aux 0 . map digitToInt . toChars+  where aux acc d = base * acc + d++escapeChar :: Stringy s => Char -> Maybe s+escapeChar = fmap fromString . flip lookup lut+  where lut = map (second (show :: Int -> String))+                  [ ('a', 0x07), ('b', 0x08), ('f', 0x0C), ('n', 0x0A)+                  , ('r', 0x0D), ('t', 0x09), ('v', 0x0B), ('\\', 0x5C)+                  , ('\'', 0x27), ('"', 0x22), ('?', 0x3F) ]++data TokChar = TokSpace Char | TokQuote | TokDQuote -- | Break a 'String' into space and non-whitespace runs.-tokWords :: String -> [Token]-tokWords [] = []-tokWords (c:cs)-  | isSpace c = let (spaces,rst) = break (not . isSpace) cs-                in Other (c : spaces) : tokWords rst-  | c == '\'' && isCharLit = goCharLit-  | c == '"' = flip skipLiteral cs $ \str rst ->-               Important (str []) : tokWords rst-  | otherwise = let (chars,rst) = break (not . validIdentifierChar) cs-                in Important (c:chars) : tokWords rst-     where (isCharLit, goCharLit) =-             case cs of-               (c':'\'':cs') -> (True, Important ['\'',c','\''] : tokWords cs')-               _ -> (False, [])+tokWords :: Stringy s => s -> [Token s]+tokWords s =+  case sbreak aux s of+     -- No word breaks+     Nothing -> [Important s] --- | If you encounter a string literal, call this helper with a--- double-barreled continuation and the rest of your input. The--- 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 ('"':cs) = k (acc . ('"':)) cs-        go acc (c:cs) = go (acc . (c :)) cs-        go acc [] = k acc []-{-# INLINE skipLiteral #-}+     -- Word delimited by space+     Just (TokSpace c, pre, pos) ->+       case sbreak (predicateJust (not . isSpace)) pos of+         Nothing -> maybeImp pre ++ [Other (cons c pos)]+         Just (c', spaces, pos') ->+           maybeImp pre +++           Other (cons c spaces) : tokWords (cons c' pos') +     -- Possible character literal+     Just (TokQuote, pre, pos) ->+       let pre' = snoc pre '\''+       in case pos of+            '\\' :. cs ->+              case sbreak (boolJust . (== '\'')) cs of+                Nothing -> [Important (pre' <> pos)]+                Just (_,esc,pos') ->+                  let esc' = if sall isOctDigit esc+                             then Important (digitsFromBase 8 esc)+                             else case esc of+                                    'x' :. hs+                                      | sall isHexDigit hs ->+                                      Important (digitsFromBase 16 hs)+                                    (escapeChar -> Just e) :. Nil -> Important e+                                    _ -> Important ("'\\" <> snoc esc '\'')+                  in  maybeImp pre ++ esc' : tokWords pos'+            c:.('\'':.cs) -> maybeImp pre+                                ++ Important (fromString ['\'', c, '\''])+                                : tokWords cs+            _:._ -> let oops = snoc pre '\''+                    in case tokWords pos of+                         (Important t:ts) -> Important (oops<>t) : ts+                         ts -> Important oops : ts+            _ -> [Important (snoc pre '\'')]++     -- String literal+     Just (TokDQuote, pre, pos) ->+       let (lit,pos') = skipLiteral pos+       in (if isEmpty pre then [] else [Important pre])+          ++ Important (cons '"' lit) : tokWords pos'+  where aux c | isSpace c = Just (TokSpace c)+              | c == '\'' = Just TokQuote+              | c == '"' = Just TokDQuote+              | otherwise = Nothing+        {-# INLINE aux #-}+{-# INLINABLE tokWords #-}++data LitStringChar = DBackSlash | EscapedDQuote | DQuote+skipLiteral :: Stringy s => s -> (s,s)+skipLiteral s =+  case breakOn [("\\\\", DBackSlash), ("\\\"", EscapedDQuote), ("\"", DQuote)] s of+    Nothing -> (s, mempty) -- Unmatched double quote?!+    Just (DBackSlash, pre, pos) -> first ((pre <> "\\\\") <>) (skipLiteral pos)+    Just (EscapedDQuote, pre, pos) -> first ((pre <> "\\\"") <>) (skipLiteral pos)+    Just (DQuote, pre, pos) -> (snoc pre '"', pos)+{-# INLINABLE skipLiteral #-}+ -- | @splits isDelimiter str@ tokenizes @str@ using @isDelimiter@ as a -- delimiter predicate. Leading whitespace is also stripped from -- tokens.-splits :: (Char -> Bool) -> String -> [String]-splits isDelim = filter (not . null) . go . dropWhile isSpace-  where go s = case break isDelim s of-                 (h,[]) -> [dropWhile isSpace h]-                 (h,d:t) -> dropWhile isSpace h : [d] : go t+splits :: Stringy s => (Char -> Bool) -> s -> [s]+splits isDelim = filter (not . isEmpty) . go . sdropWhile isSpace+  where go s = case sbreak (\c -> if isDelim c then Just c else Nothing) s of+                  Nothing -> [s]+                  Just (d, pre, pos) ->+                    pre : fromString [d] : go (sdropWhile isSpace pos)+{-# INLINE splits #-}  -- | Predicate on space characters based on something approximating -- valid identifier syntax. This is used to break apart non-space@@ -90,26 +154,36 @@  -- | Something like @12E+FOO@ is a single pre-processor token, so -- @FOO@ should not be macro expanded.-fixExponents :: [Token] -> [Token]+fixExponents :: Stringy s => [Token s] -> [Token s] fixExponents [] = []-fixExponents (Important (t1@(d1:_)):Important [c]:Important (d2:t2):ts)-  | elem c "-+" && isDigit d1 && elem (last t1) "eE" && isAlphaNum d2 =-    Important (t1++c:d2:t2) : fixExponents ts+fixExponents (t1'@(Important t1) : ts@(Important t2 : Important t3 : ts')) =+  case (,,,) <$> uncons t1 <*> unsnoc t1 <*> uncons t2 <*> uncons t3 of+    Just !(!(!d1,_), !(_,!e), !(!c,!cs), !(!d2,_))+      | elem c ("-+" :: [Char]) &&+        isEmpty cs && isDigit d1 && isAlphaNum d2 &&+        elem e ("eE" :: [Char]) -> let t = t1 <> t2 <> t3+                                   in t `seq` Important t : fixExponents ts'+    _ -> t1' : fixExponents ts fixExponents (t:ts) = t : fixExponents ts+{-# INLINABLE fixExponents #-}  -- | Break an input 'String' into a sequence of 'Tokens'. Warning: -- This may not exactly correspond to your target language's -- definition of a valid identifier!-tokenize :: String -> [Token]-tokenize = fixExponents . concatMap seps . tokWords+tokenize :: Stringy s => s -> [Token s]+tokenize = fixExponents . foldMap seps . tokWords   where seps t@(Other _) = [t]-        seps t@(Important ('"':_)) = [t]-        seps t@(Important ('\'':_)) = [t]-        seps (Important s) = map Important $-                             splits (not . validIdentifierChar) s+        seps t@(Important s) =+          case uncons s of+            Nothing -> []+            Just (c,_)+              | c == '"' -> [t]+              | c == '\'' -> [t]+              | otherwise -> map Important (splits (not . validIdentifierChar) s)+{-# INLINABLE tokenize #-}  -- | Collapse a sequence of 'Tokens' back into a 'String'. @detokenize -- . tokenize == id@.-detokenize :: [Token] -> String-detokenize = concatMap detok+detokenize :: Monoid s => [Token s] -> s+detokenize = foldMap detok {-# INLINE detokenize #-}

@@ -1,37 +1,50 @@-{-# LANGUAGE FlexibleInstances, LambdaCase #-}+{-# LANGUAGE FlexibleInstances, LambdaCase, Rank2Types #-} -- | The core types involved used by the pre-processor. module Hpp.Types where-import Control.Monad (ap, join)+import Control.Monad (ap) 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 Control.Monad.Trans.State.Strict (StateT, get, put)+import Data.ByteString.Char8 (ByteString)+import Data.Functor.Constant+import Data.Functor.Identity -- import qualified Data.Map as M+import qualified Data.Trie as T import Hpp.Config+import Hpp.Env (emptyEnv, lookupKey)+import Hpp.StringSig (toChars) import Hpp.Tokens+import Prelude hiding (String)+import qualified Prelude as P  -- | Line numbers are represented as 'Int's type LineNum = Int  -- | A macro binding environment.-type Env = [(String, Macro)]+-- type Env = [(String, Macro)] -- type Env = M.Map String Macro+type Env = T.Trie Macro +-- * Changing the underlying string type+type String = ByteString+type TOKEN = Token ByteString+ -- * Errors  -- | Error conditions we may encounter. data Error = UnterminatedBranch            | BadMacroDefinition LineNum            | BadIfPredicate-           | BadLineArgument LineNum String+           | BadLineArgument LineNum P.String            | IncludeDoesNotExist LineNum FilePath            | FailedInclude LineNum FilePath-           | UserError LineNum String-           | UnknownCommand LineNum String-           | TooFewArgumentsToMacro LineNum String-           | BadMacroArguments LineNum String+           | UserError LineNum P.String+           | UnknownCommand LineNum P.String+           | TooFewArgumentsToMacro LineNum P.String+           | BadMacroArguments LineNum P.String            | NoInputFile-           | BadCommandLine String+           | BadCommandLine P.String            | RanOutOfInput              deriving (Eq, Ord, Show) @@ -41,6 +54,7 @@  instance Monad m => HasError (ExceptT Error m) where   throwError = throwE+  {-# INLINE throwError #-}  instance (Monad m, HasHppState m) => HasHppState (ExceptT e m) where   getState = lift getState@@ -48,27 +62,13 @@   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 ())+instance (Monad m, HasError m) => HasError (StateT s m) where+  throwError = lift . throwError+  {-# INLINE throwError #-} --- | @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 ()))+instance (Monad m, HasError m) => HasError (HppT t m) where+  throwError = lift . throwError+  {-# INLINE throwError #-}  -- * Free Monad Transformers @@ -85,23 +85,18 @@ -- | 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 HppF t r = ReadFile Int FilePath (t -> r)               | ReadNext Int FilePath (t -> r)-              | GetState (HppState -> r)-              | SetState HppState r-              | ThrowError Error+              | WriteOutput t r  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+  fmap f (WriteOutput o k) = WriteOutput o (f k)   {-# INLINE fmap #-}  -- * Hpp Monad Transformer@@ -109,6 +104,10 @@ -- | 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)) } +writeOutput :: Monad m => t -> HppT t m ()+writeOutput = HppT . return . FreeF . flip WriteOutput (return ())+{-# INLINE writeOutput #-}+ instance Functor m => Functor (HppT t m) where   fmap f (HppT x) = HppT $ fmap f' x     where f' (PureF y) = PureF (f y)@@ -127,7 +126,6 @@   HppT ma >>= fb = HppT $ ma >>= \case                      PureF x -> runHppT $ fb x                      FreeF x -> return . FreeF $ fmap (>>= fb) x-  {-# INLINE (>>=) #-}  instance MonadTrans (HppT t) where   lift = HppT . fmap PureF@@ -142,27 +140,47 @@   getState :: m HppState   setState :: HppState -> m () -instance Monad m => HasHppState (HppT t m) where-  getState = HppT . pure . FreeF $ GetState pure+instance {-# OVERLAPS #-} Monad m => HasHppState (StateT HppState m) where+  getState = get   {-# INLINE getState #-}-  setState s = HppT . pure . FreeF $ SetState s (pure ())+  setState = put   {-# INLINE setState #-} +instance (Monad m, HasHppState m) => HasHppState (StateT s m) where+  getState = lift getState+  {-# INLINE getState #-}+  setState = lift . setState+  {-# INLINE setState #-}++instance (Monad m, HasHppState m) => HasHppState (HppT t m) where+  getState = lift getState+  {-# INLINE getState #-}+  setState = lift . setState+  {-# 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+instance (Monad m, HasHppState m) => HasEnv (HppT t m) where+  getEnv = fmap hppEnv (lift getState)   {-# INLINE getEnv #-}-  setEnv e = getState >>= setState . (\s -> s { hppEnv = e })+  setEnv e = lift getState >>= lift . setState . (\s -> s { hppEnv = e })   {-# INLINE setEnv #-} -instance Applicative m => HasError (HppT t m) where-  throwError = HppT . pure . FreeF . ThrowError-  {-# INLINE throwError #-}+instance Monad m => HasEnv (StateT HppState m) where+  getEnv = hppEnv <$> get+  {-# INLINE getEnv #-}+  setEnv = (env .=)+  {-# INLINE setEnv #-} +instance Monad m => HasEnv (StateT Env m) where+  getEnv = get+  {-# INLINE getEnv #-}+  setEnv = put+  {-# INLINE setEnv #-}+ instance (HasEnv m, Monad m) => HasEnv (ExceptT e m) where   getEnv = lift getEnv   {-# INLINE getEnv #-}@@ -172,10 +190,10 @@ -- * Expansion  -- | Macro expansion involves treating tokens differently if they--- appear in the original source for or as the result of a previous--- macro expansion. This distinction is used to prevent divergence by+-- appear in the original source or as the result of a previous macro+-- expansion. This distinction is used to prevent divergence by -- masking out definitions that could be used recursively.--- +-- -- Things are made somewhat more complicated than one might expect due -- to the fact that the scope of this masking is /not/ structurally -- recursive. A object-like macro can expand into a fragment of a@@ -184,21 +202,75 @@ -- be expanded. data Scan = Unmask String           | Mask String-          | Scan Token-          | Rescan Token+          | Scan (Token String)+          | Rescan (Token String)             deriving (Eq, Show)  -- * Macros  -- | There are object-like macros and function-like macros.-data Macro = Object [Token]+data Macro = Object [Token String]            -- ^ An object-like macro is replaced with its definition-           | Function Int ([([Scan],String)] -> [Scan])+           | Function Int ([([Scan], String)] -> [Scan])            -- ^ A function-like macro of some arity taks            -- macro-expanded and raw versions of its arguments, then            -- substitutes them into a body producing a new set of            -- tokens.  instance Show Macro where-  show (Object ts) = "Object "++ detokenize ts-  show (Function n _) = "Fun<"++show n++">" +  show (Object ts) = "Object "++ toChars (detokenize ts)+  show (Function n _) = "Fun<"++show n++">"++-- | Looks up a 'Macro' in the current environment. If the 'Macro' is+-- found, the environment is juggled so that subsequent lookups of the+-- same 'Macro' may evaluate more quickly.+lookupMacro :: (HasEnv m, Monad m) => String -> m (Maybe Macro)+lookupMacro s = lookupKey s <$> getEnv+{-# INLINE lookupMacro #-}++-- * Nano-lens++type Lens s a = forall f. Functor f => (a -> f a) -> s -> f s++setL :: Lens s a -> a -> s -> s+setL l x = runIdentity . l (const $ Identity x)+{-# INLINE setL #-}++getL :: Lens s a -> s -> a+getL l = getConstant . l Constant+{-# INLINE getL #-}++over :: Lens s a -> (a -> a) -> s -> s+over l f = runIdentity . l (Identity . f)+{-# INLINE over #-}++-- * State Lenses++emptyHppState :: Config -> HppState+emptyHppState cfg = HppState cfg 1 emptyEnv++config :: Lens HppState Config+config f (HppState cfg ln e) = (\cfg' -> HppState cfg' ln e) <$> f cfg+{-# INLINE config #-}++lineNum :: Lens HppState LineNum+lineNum f (HppState cfg ln e) = (\ln' -> HppState cfg ln' e) <$> f ln+{-# INLINE lineNum #-}++env :: Lens HppState Env+env f (HppState cfg ln e) = (\e' -> HppState cfg ln e') <$> f e+{-# INLINE env #-}++use :: (HasHppState m, Functor m) => Lens HppState a -> m a+use l = getL l <$> getState+{-# INLINE use #-}++(.=) :: (HasHppState m, Monad m) => Lens HppState a -> a -> m ()+l .= x = getState >>= setState . setL l x+infix 4 .=+{-# INLINE (.=) #-}++(%=) :: (HasHppState m, Monad m) => Lens HppState a -> (a -> a) -> m ()+l %= f = getState >>= setState . over l f+infix 4 %=+{-# INLINE (%=) #-}

@@ -25,12 +25,17 @@   , "  Like -include, except that output is discarded. Only"   , "  macro definitions are kept."   , "--cpp"-  , "  C98 compatibility. Implies: --fline-splice --ferase-comments"+  , "  C98 compatibility."+  , "  Implies: --fline-splice --ferase-comments --freplace-trigraphs"   , "  -D __STDC__  -D __STDC_VERSION__=199409L -D _POSIX_C_SOURCE=200112L"+  , "-P"+  , "  Inhibit #line markers (when this option is given after --cpp)"   , "--fline-splice"   , "  Enable continued line splicing."   , "--ferase-comments"-  , "  Remove all C-style comments before processing." ]+  , "  Remove all C-style comments before processing."+  , "--freplace-trigraphs"+  , "  Replace trigraph sequences before processing." ]  main :: IO () main = do getArgs >>= \case@@ -46,6 +51,6 @@  For the mcpp validation suite -../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 +../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  -}

@@ -5,7 +5,7 @@ GCC=gcc  # Note: head -n -1 would be faster than "sed '$ d'", but doesn't work-# with BSD or OS X head. +# with BSD or OS X head.  # Get the include paths GCC will use by default. GCCDIR=($(echo | ${GCC} -E -v - 2>&1 | sed -n '/#include <...> search starts/,/End of search list/ p' | tail -n +2 | sed '$ d' | grep -v '(framework directory)' | sed 's/^[[:space:]]*//'))@@ -32,7 +32,11 @@ fi  echo 'Building hpp'-(cd .. && cabal build)+if [ -z "$TRAVIS" ]; then+  (cd .. && stack build hpp:hpp)+else+  (cd .. && cabal build)+fi if ! [ $? -eq 0 ]; then   echo 'Building hpp failed'   exit 1@@ -48,7 +52,11 @@ # Note that we define __i386__ as the architecture as the MCPP # validation test n_12.c assumes a long is 32 bits. -(cd mcpp-2.7.2/test-c &&  ../tool/cpp_test HPP "../../../dist/build/hpp/hpp -I/usr/include ${GCCDIR} --cpp -D__i386__ -D__DARWIN_ONLY_UNIX_CONFORMANCE %s.c | gcc -o %s -w -x c -" "rm %s" < n_i_.lst)+if [ -z "$TRAVIS" ]; then+  (cd mcpp-2.7.2/test-c &&  ../tool/cpp_test HPP "$(cd ../../.. && stack exec which -- hpp) -I/usr/include ${GCCDIR} --cpp -D__i386__ -D__DARWIN_ONLY_UNIX_CONFORMANCE %s.c | gcc -o %s -w -x c -" "rm %s" < n_i_.lst)+else+  (cd mcpp-2.7.2/test-c &&  ../tool/cpp_test HPP "$(find ../../../dist -type f -executable -name hpp) -I/usr/include ${GCCDIR} --cpp -D__i386__ -D__DARWIN_ONLY_UNIX_CONFORMANCE %s.c | gcc -o %s -w -x c -" "rm %s" < n_i_.lst)+fi  if ! [ $? -eq 0 ]; then   echo 'The test runner exited with an error.'