diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -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). diff --git a/hpp.cabal b/hpp.cabal --- a/hpp.cabal +++ b/hpp.cabal @@ -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. - . - - @ - {-\# OPTIONS_GHC -cpp -pgmPhpp -optP\-\-cpp \#-} - @ - - +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 diff --git a/src/Hpp.hs b/src/Hpp.hs --- a/src/Hpp.hs +++ b/src/Hpp.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) diff --git a/src/Hpp/CmdLine.hs b/src/Hpp/CmdLine.hs --- a/src/Hpp/CmdLine.hs +++ b/src/Hpp/CmdLine.hs @@ -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 diff --git a/src/Hpp/Config.hs b/src/Hpp/Config.hs --- a/src/Hpp/Config.hs +++ b/src/Hpp/Config.hs @@ -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 "??:??:??")) diff --git a/src/Hpp/Env.hs b/src/Hpp/Env.hs --- a/src/Hpp/Env.hs +++ b/src/Hpp/Env.hs @@ -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 #-} +-} diff --git a/src/Hpp/Expansion.hs b/src/Hpp/Expansion.hs --- a/src/Hpp/Expansion.hs +++ b/src/Hpp/Expansion.hs @@ -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] diff --git a/src/Hpp/Expr.hs b/src/Hpp/Expr.hs --- a/src/Hpp/Expr.hs +++ b/src/Hpp/Expr.hs @@ -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 diff --git a/src/Hpp/Parser.hs b/src/Hpp/Parser.hs --- a/src/Hpp/Parser.hs +++ b/src/Hpp/Parser.hs @@ -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 #-} diff --git a/src/Hpp/StreamIO.hs b/src/Hpp/StreamIO.hs deleted file mode 100644 --- a/src/Hpp/StreamIO.hs +++ /dev/null @@ -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_) diff --git a/src/Hpp/Streamer.hs b/src/Hpp/Streamer.hs deleted file mode 100644 --- a/src/Hpp/Streamer.hs +++ /dev/null @@ -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) - #-} diff --git a/src/Hpp/String.hs b/src/Hpp/String.hs --- a/src/Hpp/String.hs +++ b/src/Hpp/String.hs @@ -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] diff --git a/src/Hpp/StringSig.hs b/src/Hpp/StringSig.hs new file mode 100644 --- /dev/null +++ b/src/Hpp/StringSig.hs @@ -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 diff --git a/src/Hpp/Tokens.hs b/src/Hpp/Tokens.hs --- a/src/Hpp/Tokens.hs +++ b/src/Hpp/Tokens.hs @@ -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 #-} diff --git a/src/Hpp/Types.hs b/src/Hpp/Types.hs --- a/src/Hpp/Types.hs +++ b/src/Hpp/Types.hs @@ -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 (%=) #-} diff --git a/src/Main.hs b/src/Main.hs --- a/src/Main.hs +++ b/src/Main.hs @@ -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 -} diff --git a/tests/mcpp-validation.sh b/tests/mcpp-validation.sh --- a/tests/mcpp-validation.sh +++ b/tests/mcpp-validation.sh @@ -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.'