diff --git a/CHANGELOG b/CHANGELOG
--- a/CHANGELOG
+++ b/CHANGELOG
@@ -1,3 +1,7 @@
+Version 1.11
+------------
+ * API change: runCpphs, cppIfdef, and macroPass are now in the IO monad.
+
Version 1.10
-----------
* New command-line option: "--linepragma"
diff --git a/Language/Preprocessor/Cpphs/CppIfdef.hs b/Language/Preprocessor/Cpphs/CppIfdef.hs
--- a/Language/Preprocessor/Cpphs/CppIfdef.hs
+++ b/Language/Preprocessor/Cpphs/CppIfdef.hs
@@ -14,7 +14,7 @@
module Language.Preprocessor.Cpphs.CppIfdef
( cppIfdef -- :: FilePath -> [(String,String)] -> [String] -> Options
- -- -> String -> [(Posn,String)]
+ -- -> String -> IO [(Posn,String)]
) where
@@ -30,7 +30,7 @@
import Language.Preprocessor.Cpphs.MacroPass (preDefine,defineMacro)
import Char (isDigit)
import Numeric (readHex,readOct,readDec)
-import System.IO.Unsafe (unsafePerformIO)
+import System.IO.Unsafe (unsafeInterleaveIO)
import IO (hPutStrLn,stderr)
@@ -41,7 +41,7 @@
-> [String] -- ^ Search path for \#includes
-> BoolOptions -- ^ Options controlling output style
-> String -- ^ The input file content
- -> [(Posn,String)] -- ^ The file after processing (in lines)
+ -> IO [(Posn,String)] -- ^ The file after processing (in lines)
cppIfdef fp syms search options =
cpp posn defs search options Keep . (cppline posn:) . linesCpp
where
@@ -60,8 +60,8 @@
-- | Return just the list of lines that the real cpp would decide to keep.
cpp :: Posn -> SymTab HashDefine -> [String] -> BoolOptions -> KeepState
- -> [String] -> [(Posn,String)]
-cpp _ _ _ _ _ [] = []
+ -> [String] -> IO [(Posn,String)]
+cpp _ _ _ _ _ [] = return []
cpp p syms path options Keep (l@('#':x):xs) =
let ws = words x
@@ -74,8 +74,8 @@
keepIf p = if p then Keep else (Drop 1 False)
skipn syms' retain ud xs' =
let n = 1 + length (filter (=='\n') l) in
- (if macros options && retain then ((p,reslash l):)
- else (replicate n (p,"") ++)) $
+ (if macros options && retain then emitOne (p,reslash l)
+ else emitMany (replicate n (p,""))) $
cpp (newlines n p) syms' path options ud xs'
in case cmd of
"define" -> skipn (insertST def syms) True Keep xs
@@ -89,39 +89,37 @@
"endif" -> skipn syms False Keep xs
"pragma" -> skipn syms True Keep xs
('!':_) -> skipn syms False Keep xs -- \#!runhs scripts
- "include"-> let (inc,content) =
- unsafePerformIO (readFirst (file syms (unwords line))
- p path
- (warnings options))
- in
- cpp p syms path options Keep (("#line 1 "++show inc)
- : linesCpp content
- ++ cppline (newline p): xs)
- "warning"-> if warnings options then unsafePerformIO $ do
- hPutStrLn stderr (l++"\nin "++show p)
- return $ skipn syms False Keep xs
+ "include"-> do (inc,content) <- readFirst (file syms (unwords line))
+ p path
+ (warnings options)
+ cpp p syms path options Keep (("#line 1 "++show inc)
+ : linesCpp content
+ ++ cppline (newline p): xs)
+ "warning"-> if warnings options then
+ do hPutStrLn stderr (l++"\nin "++show p)
+ skipn syms False Keep xs
else skipn syms False Keep xs
"error" -> error (l++"\nin "++show p)
"line" | all isDigit sym
- -> (if locations options && hashline options then ((p,l):)
- else if locations options then ((p,cpp2hask l):)
+ -> (if locations options && hashline options then emitOne (p,l)
+ else if locations options then emitOne (p,cpp2hask l)
else id) $
cpp (newpos (read sym) (un rest) p)
syms path options Keep xs
n | all isDigit n
- -> (if locations options && hashline options then ((p,l):)
- else if locations options then ((p,cpp2hask l):)
+ -> (if locations options && hashline options then emitOne (p,l)
+ else if locations options then emitOne (p,cpp2hask l)
else id) $
cpp (newpos (read n) (un (tail ws)) p)
syms path options Keep xs
| otherwise
- -> if warnings options then unsafePerformIO $ do
- hPutStrLn stderr ("Warning: unknown directive #"++n
- ++"\nin "++show p)
- return $
- ((p,l): cpp (newline p) syms path options Keep xs)
- else
- ((p,l): cpp (newline p) syms path options Keep xs)
+ -> if warnings options then
+ do hPutStrLn stderr ("Warning: unknown directive #"++n
+ ++"\nin "++show p)
+ emitOne (p,l) $
+ cpp (newline p) syms path options Keep xs
+ else emitOne (p,l) $
+ cpp (newline p) syms path options Keep xs
cpp p syms path options (Drop n b) (('#':x):xs) =
let ws = words x
@@ -136,8 +134,8 @@
| otherwise = Drop n b
skipn ud xs' =
let n' = 1 + length (filter (=='\n') x) in
- replicate n' (p,"")
- ++ cpp (newlines n' p) syms path options ud xs'
+ emitMany (replicate n' (p,"")) $
+ cpp (newlines n' p) syms path options ud xs'
in
if cmd == "ifndef" ||
cmd == "if" ||
@@ -150,10 +148,19 @@
cpp p syms path options Keep (x:xs) =
let p' = newline p in seq p' $
- (p,x): cpp p' syms path options Keep xs
+ emitOne (p,x) $ cpp p' syms path options Keep xs
cpp p syms path options d@(Drop _ _) (_:xs) =
let p' = newline p in seq p' $
- (p,""): cpp p' syms path options d xs
+ emitOne (p,"") $ cpp p' syms path options d xs
+
+
+-- | Auxiliary IO functions
+emitOne :: a -> IO [a] -> IO [a]
+emitMany :: [a] -> IO [a] -> IO [a]
+emitOne x io = do ys <- unsafeInterleaveIO io
+ return (x:ys)
+emitMany xs io = do ys <- unsafeInterleaveIO io
+ return (xs++ys)
----
diff --git a/Language/Preprocessor/Cpphs/MacroPass.hs b/Language/Preprocessor/Cpphs/MacroPass.hs
--- a/Language/Preprocessor/Cpphs/MacroPass.hs
+++ b/Language/Preprocessor/Cpphs/MacroPass.hs
@@ -25,7 +25,8 @@
, emptyST)
import Language.Preprocessor.Cpphs.Position (Posn, newfile, filename, lineno)
import Language.Preprocessor.Cpphs.Options (BoolOptions(..))
-import System.IO.Unsafe (unsafePerformIO)
+import System.IO.Unsafe (unsafeInterleaveIO)
+import Control.Monad ((=<<))
import Time (getClockTime, toCalendarTime, formatCalendarTime)
import Locale (defaultTimeLocale)
@@ -36,10 +37,10 @@
macroPass :: [(String,String)] -- ^ Pre-defined symbols and their values
-> BoolOptions -- ^ Options that alter processing style
-> [(Posn,String)] -- ^ The input file content
- -> String -- ^ The file after processing
+ -> IO String -- ^ The file after processing
macroPass syms options =
- safetail -- to remove extra "\n" inserted below
- . concat
+ fmap (safetail -- to remove extra "\n" inserted below
+ . concat)
. macroProcess (pragma options) (layout options) (lang options)
(preDefine options syms)
. tokenise (stripEol options) (stripC89 options)
@@ -73,58 +74,68 @@
-- of that name in the symbol table, and if so, expanded appropriately.
-- (Bool arguments are: keep pragmas? retain layout? haskell language?)
macroProcess :: Bool -> Bool -> Bool -> SymTab HashDefine -> [WordStyle]
- -> [String]
-macroProcess _ _ _ _ [] = []
-macroProcess p y l st (Other x: ws) = x: macroProcess p y l st ws
-macroProcess p y l st (Cmd Nothing: ws) = "\n": macroProcess p y l st ws
+ -> IO [String]
+macroProcess _ _ _ _ [] = return []
+macroProcess p y l st (Other x: ws) = emit x $ macroProcess p y l st ws
+macroProcess p y l st (Cmd Nothing: ws) = emit "\n" $ macroProcess p y l st ws
macroProcess p y l st (Cmd (Just (LineDrop x)): ws)
- = "\n":x:macroProcess p y l st ws
+ = emit "\n" $
+ emit x $ macroProcess p y l st ws
macroProcess pragma y l st (Cmd (Just (Pragma x)): ws)
- | pragma = "\n":x:macroProcess pragma y l st ws
- | otherwise = "\n": macroProcess pragma y l st ws
+ | pragma = emit "\n" $ emit x $ macroProcess pragma y l st ws
+ | otherwise = emit "\n" $ macroProcess pragma y l st ws
macroProcess p layout lang st (Cmd (Just hd): ws) =
let n = 1 + linebreaks hd in
- replicate n "\n" ++macroProcess p layout lang (insertST (name hd, hd) st) ws
+ emit (replicate n '\n') $
+ macroProcess p layout lang (insertST (name hd, hd) st) ws
macroProcess pr layout lang st (Ident p x: ws) =
case x of
- "__FILE__" -> show (filename p): macroProcess pr layout lang st ws
- "__LINE__" -> show (lineno p): macroProcess pr layout lang st ws
- "__DATE__" -> formatCalendarTime defaultTimeLocale "\"%d %b %Y\""
- (unsafePerformIO (getClockTime>>=toCalendarTime)):
- macroProcess pr layout lang st ws
- "__TIME__" -> formatCalendarTime defaultTimeLocale "\"%H:%M:%S\""
- (unsafePerformIO (getClockTime>>=toCalendarTime)):
- macroProcess pr layout lang st ws
+ "__FILE__" -> emit (show (filename p))$ macroProcess pr layout lang st ws
+ "__LINE__" -> emit (show (lineno p)) $ macroProcess pr layout lang st ws
+ "__DATE__" -> do w <- return .
+ formatCalendarTime defaultTimeLocale "\"%d %b %Y\""
+ =<< toCalendarTime =<< getClockTime
+ emit w $ macroProcess pr layout lang st ws
+ "__TIME__" -> do w <- return .
+ formatCalendarTime defaultTimeLocale "\"%H:%M:%S\""
+ =<< toCalendarTime =<< getClockTime
+ emit w $ macroProcess pr layout lang st ws
_ ->
case lookupST x st of
- Nothing -> x: macroProcess pr layout lang st ws
+ Nothing -> emit x $ macroProcess pr layout lang st ws
Just hd ->
case hd of
- AntiDefined {name=n} -> n: macroProcess pr layout lang st ws
+ AntiDefined {name=n} -> emit n $
+ macroProcess pr layout lang st ws
SymbolReplacement {replacement=r} ->
let r' = if layout then r else filter (/='\n') r in
-- one-level expansion only:
- -- r' : macroProcess layout st ws
+ -- emit r' $ macroProcess layout st ws
-- multi-level expansion:
macroProcess pr layout lang st
(tokenise True True False lang [(p,r')]
++ ws)
MacroExpansion {} ->
case parseMacroCall p ws of
- Nothing -> x: macroProcess pr layout lang st ws
+ Nothing -> emit x $
+ macroProcess pr layout lang st ws
Just (args,ws') ->
if length args /= length (arguments hd) then
- x: macroProcess pr layout lang st ws
- else let args' = map (concat
- . macroProcess pr layout
- lang st)
- args in
- -- one-level expansion only:
- -- expandMacro hd args' layout:
- -- macroProcess layout st ws'
- -- multi-level expansion:
- macroProcess pr layout lang st
- (tokenise True True False lang
- [(p,expandMacro hd args' layout)]
- ++ ws')
+ emit x $ macroProcess pr layout lang st ws
+ else do args' <- mapM (fmap concat .
+ macroProcess pr layout
+ lang st)
+ args
+ -- one-level expansion only:
+ -- emit (expandMacro hd args' layout) $
+ -- macroProcess layout st ws'
+ -- multi-level expansion:
+ macroProcess pr layout lang st
+ (tokenise True True False lang
+ [(p,expandMacro hd args' layout)]
+ ++ ws')
+-- | Useful helper function.
+emit :: a -> IO [a] -> IO [a]
+emit x io = do xs <- unsafeInterleaveIO io
+ return (x:xs)
diff --git a/Language/Preprocessor/Cpphs/RunCpphs.hs b/Language/Preprocessor/Cpphs/RunCpphs.hs
--- a/Language/Preprocessor/Cpphs/RunCpphs.hs
+++ b/Language/Preprocessor/Cpphs/RunCpphs.hs
@@ -13,18 +13,18 @@
import Language.Preprocessor.Unlit as Unlit (unlit)
-runCpphs :: CpphsOptions -> FilePath -> String -> String
-runCpphs options filename input =
- let bools = boolopts options
+runCpphs :: CpphsOptions -> FilePath -> String -> IO String
+runCpphs options filename input = do
+ let bools = boolopts options
preInc = case preInclude options of
[] -> ""
is -> concatMap (\f->"#include \""++f++"\"\n") is
++ "#line 1 \""++filename++"\"\n"
- pass1 = cppIfdef filename (defines options) (includes options) bools
- (preInc++input)
- pass2 = macroPass (defines options) bools pass1
- result= if not (macros bools) then unlines (map snd pass1) else pass2
+ pass1 <- cppIfdef filename (defines options) (includes options) bools
+ (preInc++input)
+ pass2 <- macroPass (defines options) bools pass1
+ let result= if not (macros bools) then unlines (map snd pass1) else pass2
pass3 = if literate bools then Unlit.unlit filename else id
- in pass3 result
+ return (pass3 result)
diff --git a/Makefile b/Makefile
--- a/Makefile
+++ b/Makefile
@@ -1,5 +1,5 @@
LIBRARY = cpphs
-VERSION = 1.10
+VERSION = 1.11
DIRS = Language/Preprocessor/Cpphs \
Text/ParserCombinators
diff --git a/cpphs.cabal b/cpphs.cabal
--- a/cpphs.cabal
+++ b/cpphs.cabal
@@ -1,5 +1,5 @@
Name: cpphs
-Version: 1.10
+Version: 1.11
Copyright: 2004-2010, Malcolm Wallace
Build-Depends: base < 6, haskell98
License: LGPL
diff --git a/cpphs.hs b/cpphs.hs
--- a/cpphs.hs
+++ b/cpphs.hs
@@ -19,7 +19,7 @@
import List ( isPrefixOf )
version :: String
-version = "1.10"
+version = "1.11"
main :: IO ()
main = do
@@ -64,7 +64,8 @@
output Nothing x = do putStr x; hFlush stdout
output (Just f) x = writeFile f x
in do contents <- readIt
- output ofile (runCpphs opts filename contents)
+ transformed <- runCpphs opts filename contents
+ output ofile transformed
isLeft (Left _) = True
isLeft _ = False
diff --git a/docs/index.html b/docs/index.html
--- a/docs/index.html
+++ b/docs/index.html
@@ -198,13 +198,13 @@
Current stable version:
-cpphs-1.10, release date 2010.01.30
+cpphs-1.11, release date 2010.01.31
By HTTP:
-.tar.gz,
-.zip,
+.tar.gz,
+.zip,
Hackage.
-- New command-line flag: --linepragma
+
- Major API change: runCpphs, cppIfdef and macroPass are now in the IO monad.
@@ -226,6 +226,15 @@
Older versions:
+
+
+cpphs-1.10, release date 2010.01.30
+By HTTP:
+.tar.gz,
+.zip,
+
+- New command-line flag: --linepragma
+
cpphs-1.9, release date 2009.09.07