Macro expansion text is divided into sections, each of which is classified
+ as one of three kinds: a formal argument (Arg), plain text (Text),
+ or a stringised formal argument (Str).
+
Attempt to read the given file from any location within the search path.
+ The first location found is returned, together with the file content.
+ (The directory of the calling file is always searched first, then
+ the current directory, finally any specified search path.)
+
The purpose of this module is to lex a source file (language
+ unspecified) into tokens such that cpp can recognise a replaceable
+ symbol or macro-use, and do the right thing.
+
linesCpp is, broadly speaking, Prelude.lines, except that
+ on a line beginning with a #, line continuation characters are
+ recognised. In a line continuation, the newline character is
+ preserved, but the backslash is not.
+
tokenise is, broadly-speaking, Prelude.words, except that:
+ * the input is already divided into lines
+ * each word-like token is categorised as one of {Ident,Other,Cmd}
+ * #define's are parsed and returned out-of-band using the Cmd variant
+ * All whitespace is preserved intact as tokens.
+ * C-comments are converted to white-space (depending on first param)
+ * Parens and commas are tokens in their own right.
+ * Any cpp line continuations are respected.
+ No errors can be raised.
+ The inverse of tokenise is (concatMap deWordStyle).
+
Each token is classified as one of Ident, Other, or Cmd:
+ * Ident is a word that could potentially match a macro name.
+ * Cmd is a complete cpp directive (#define etc).
+ * Other is anything else.
+
-----------------------------------------------------------------------------
+-- |
+-- Module : MacroPass
+-- Copyright : 2004 Malcolm Wallace
+-- Licence : LGPL
+--
+-- Maintainer : Malcolm Wallace <Malcolm.Wallace@cs.york.ac.uk>
+-- Stability : experimental
+-- Portability : All
+--
+-- Perform a cpp.second-pass, accumulating \#define's and \#undef's,
+-- whilst doing symbol replacement and macro expansion.
+-----------------------------------------------------------------------------
+
+module Language.Preprocessor.Cpphs.MacroPass
+ ( macroPass
+ , preDefine
+ , defineMacro
+ ) where
+
+import Language.Preprocessor.Cpphs.HashDefine (HashDefine(..), expandMacro)
+import Language.Preprocessor.Cpphs.Tokenise (tokenise, WordStyle(..)
+ , parseMacroCall)
+import Language.Preprocessor.Cpphs.SymTab (SymTab, lookupST, insertST
+ , emptyST)
+import Language.Preprocessor.Cpphs.Position (Posn, newfile, filename, lineno)
+import Language.Preprocessor.Cpphs.Options (BoolOptions(..))
+import System.IO.Unsafe (unsafePerformIO)
+import Time (getClockTime, toCalendarTime, formatCalendarTime)
+import Locale (defaultTimeLocale)
+
+noPos :: Posn
+noPos = newfile "preDefined"
+
+-- | Walk through the document, replacing calls of macros with the expanded RHS.
+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
+macroPass syms options =
+ safetail -- to remove extra "\n" inserted below
+ . concat
+ . macroProcess (pragma options) (layout options) (lang options)
+ (preDefine options syms)
+ . tokenise (strip options) (ansi options) (lang options)
+ . ((noPos,""):) -- ensure recognition of "\n#" at start of file
+ where
+ safetail [] = []
+ safetail (_:xs) = xs
+
+
+-- | Turn command-line definitions (from @-D@) into 'HashDefine's.
+preDefine :: BoolOptions -> [(String,String)] -> SymTab HashDefine
+preDefine options defines =
+ foldr (insertST . defineMacro options . (\ (s,d)-> s++" "++d))
+ emptyST defines
+
+-- | Turn a string representing a macro definition into a 'HashDefine'.
+defineMacro :: BoolOptions -> String -> (String,HashDefine)
+defineMacro opts s =
+ let (Cmd (Just hd):_) = tokenise True (ansi opts) (lang opts)
+ [(noPos,"\n#define "++s++"\n")]
+ in (name hd, hd)
+
+
+-- | Trundle through the document, one word at a time, using the WordStyle
+-- classification introduced by 'tokenise' to decide whether to expand a
+-- word or macro. Encountering a \#define or \#undef causes that symbol to
+-- be overwritten in the symbol table. Any other remaining cpp directives
+-- are discarded and replaced with blanks, except for \#line markers.
+-- All valid identifiers are checked for the presence of a definition
+-- 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
+macroProcess p y l st (Cmd (Just (LineDrop x)): ws)
+ = "\n":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
+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
+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
+ _ ->
+ case lookupST x st of
+ Nothing -> x: macroProcess pr layout lang st ws
+ Just hd ->
+ case hd of
+ SymbolReplacement {replacement=r} ->
+ let r' = if layout then r else filter (/='\n') r in
+ -- one-level expansion only:
+ -- r' : macroProcess layout st ws
+ -- multi-level expansion:
+ macroProcess pr layout lang st
+ (tokenise True False lang [(p,r')]
+ ++ ws)
+ MacroExpansion {} ->
+ case parseMacroCall p ws of
+ Nothing -> x: macroProcess pr layout lang st ws
+ Just (args,ws') ->
+ if length args /= length (arguments hd) then
+ x: macroProcess pr layout lang st ws
+ elselet 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 False lang
+ [(p,expandMacro hd args' layout)]
+ ++ ws')
+
+
-----------------------------------------------------------------------------
+-- |
+-- Module : Position
+-- Copyright : 2000-2004 Malcolm Wallace
+-- Licence : LGPL
+--
+-- Maintainer : Malcolm Wallace <Malcolm.Wallace@cs.york.ac.uk>
+-- Stability : experimental
+-- Portability : All
+--
+-- Simple file position information, with recursive inclusion points.
+-----------------------------------------------------------------------------
+
+module Language.Preprocessor.Cpphs.Position
+ ( Posn(..)
+ , newfile
+ , addcol, newline, tab, newlines, newpos
+ , cppline
+ , filename, lineno, directory
+ ) where
+
+-- | Source positions contain a filename, line, column, and an
+-- inclusion point, which is itself another source position,
+-- recursively.
+data Posn = Pn String !Int !Int (Maybe Posn)
+ deriving (Eq)
+
+instance Show Posn where
+ showsPrec _ (Pn f l c i) = showString f .
+ showString " at line " . shows l .
+ showString " col " . shows c .
+ ( case i of
+ Nothing -> id
+ Just p -> showString "\n used by " .
+ shows p )
+
+-- | Constructor
+newfile :: String -> Posn
+newfile name = Pn name 1 1 Nothing
+
+-- | Updates
+addcol :: Int -> Posn -> Posn
+addcol n (Pn f r c i) = Pn f r (c+n) i
+
+newline, tab :: Posn -> Posn
+--newline (Pn f r _ i) = Pn f (r+1) 1 i
+newline (Pn f r _ i) = let r' = r+1 in r' `seq` Pn f r' 1 i
+tab (Pn f r c i) = Pn f r (((c`div`8)+1)*8) i
+
+newlines :: Int -> Posn -> Posn
+newlines n (Pn f r _ i) = Pn f (r+n) 1 i
+
+newpos :: Int -> Maybe String -> Posn -> Posn
+newpos r Nothing (Pn f _ c i) = Pn f r c i
+newpos r (Just ('"':f)) (Pn __ c i) = Pn (init f) r c i
+newpos r (Just f) (Pn __ c i) = Pn f r c i
+
+-- | Projections
+
+lineno :: Posn -> Int
+filename :: Posn -> String
+directory :: Posn -> FilePath
+
+lineno (Pn _ r __) = r
+filename (Pn f ___) = f
+directory (Pn f ___) = dirname f
+
+
+-- | cpp-style printing
+cppline :: Posn -> String
+cppline (Pn f r __) = "#line "++show r++" "++show f
+
+
+-- | Strip non-directory suffix from file name (analogous to the shell
+-- command of the same name).
+dirname :: String -> String
+dirname = reverse . safetail . dropWhile (not.(`elem`"\\/")) . reverse
+ where safetail [] = []
+ safetail (_:x) = x
+
+
{-
+-- The main program for cpphs, a simple C pre-processor written in Haskell.
+
+-- Copyright (c) 2004 Malcolm Wallace
+-- This file is GPL, although the libraries it uses are either standard
+-- Haskell'98 or distributed under the LGPL.
+-}
+module Language.Preprocessor.Cpphs.RunCpphs ( runCpphs ) where
+
+import Language.Preprocessor.Cpphs.CppIfdef (cppIfdef)
+import Language.Preprocessor.Cpphs.MacroPass(macroPass)
+import Language.Preprocessor.Cpphs.Options (CpphsOptions(..), BoolOptions(..))
+import Language.Preprocessor.Unlit as Unlit (unlit)
+
+
+runCpphs :: CpphsOptions -> FilePath -> String -> String
+runCpphs options filename input =
+ let bools = boolopts options
+
+ pass1 = cppIfdef filename (defines options) (includes options) bools input
+ pass2 = macroPass (defines options) bools pass1
+ 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
+
-----------------------------------------------------------------------------
+-- |
+-- Module : SymTab
+-- Copyright : 2000-2004 Malcolm Wallace
+-- Licence : LGPL
+--
+-- Maintainer : Malcolm Wallace <Malcolm.Wallace@cs.york.ac.uk>
+-- Stability : Stable
+-- Portability : All
+--
+-- Symbol Table, based on index trees using a hash on the key.
+-- Keys are always Strings. Stored values can be any type.
+-----------------------------------------------------------------------------
+
+module Language.Preprocessor.Cpphs.SymTab
+ ( SymTab
+ , emptyST
+ , insertST
+ , deleteST
+ , lookupST
+ , definedST
+ , IndTree
+ ) where
+
+-- | Symbol Table. Stored values are polymorphic, but the keys are
+-- always strings.
+type SymTab v = IndTree [(String,v)]
+
+emptyST :: SymTab v
+insertST :: (String,v) -> SymTab v -> SymTab v
+deleteST :: String -> SymTab v -> SymTab v
+lookupST :: String -> SymTab v -> Maybe v
+definedST :: String -> SymTab v -> Bool
+
+emptyST = itgen maxHash []
+insertST (s,v) ss = itiap (hash s) ((s,v):) ss id
+deleteST s ss = itiap (hash s) (filter ((/=s).fst)) ss id
+lookupST s ss = let vs = filter ((==s).fst) ((itind (hash s)) ss)
+ inif null vs then Nothing
+ else (Just . snd . head) vs
+definedST s ss = let vs = filter ((==s).fst) ((itind (hash s)) ss)
+ in (not . null) vs
+
+
+----
+-- | Index Trees (storing indexes at nodes).
+
+data IndTree t = Leaf t | Fork Int (IndTree t) (IndTree t)
+ deriving Show
+
+itgen :: Int -> a -> IndTree a
+itgen 1 x = Leaf x
+itgen n x =
+ let n' = n `div` 2
+ in Fork n' (itgen n' x) (itgen (n-n') x)
+
+itiap :: --Eval a =>
+ Int -> (a->a) -> IndTree a -> (IndTree a -> b) -> b
+itiap _ f (Leaf x) k = let fx = f x in {-seq fx-} (k (Leaf fx))
+itiap i f (Fork n lt rt) k =
+ if i<n then
+ itiap i f lt $ \lt' -> k (Fork n lt' rt)
+ else itiap (i-n) f rt $ \rt' -> k (Fork n lt rt')
+
+itind :: Int -> IndTree a -> a
+itind _ (Leaf x) = x
+itind i (Fork n lt rt) = if i<n then itind i lt else itind (i-n) rt
+
+
+----
+-- Hash values
+
+maxHash :: Int -- should be prime
+maxHash = 101
+
+class Hashable a where
+ hashWithMax :: Int -> a -> Int
+ hash :: a -> Int
+ hash = hashWithMax maxHash
+
+instance Enum a => Hashable [a] where
+ hashWithMax m = h 0
+ where h a [] = a
+ h a (c:cs) = h ((17*(fromEnum c)+19*a)`rem`m) cs
+
+----
+
-----------------------------------------------------------------------------
+-- |
+-- Module : Tokenise
+-- Copyright : 2004 Malcolm Wallace
+-- Licence : LGPL
+--
+-- Maintainer : Malcolm Wallace <Malcolm.Wallace@cs.york.ac.uk>
+-- Stability : experimental
+-- Portability : All
+--
+-- The purpose of this module is to lex a source file (language
+-- unspecified) into tokens such that cpp can recognise a replaceable
+-- symbol or macro-use, and do the right thing.
+-----------------------------------------------------------------------------
+
+module Language.Preprocessor.Cpphs.Tokenise
+ ( linesCpp
+ , reslash
+ , tokenise
+ , WordStyle(..)
+ , deWordStyle
+ , parseMacroCall
+ ) where
+
+import Char
+import Language.Preprocessor.Cpphs.HashDefine
+import Language.Preprocessor.Cpphs.Position
+
+-- | A Mode value describes whether to tokenise a la Haskell, or a la Cpp.
+-- The main difference is that in Cpp mode we should recognise line
+-- continuation characters.
+data Mode = Haskell | Cpp
+
+-- | linesCpp is, broadly speaking, Prelude.lines, except that
+-- on a line beginning with a \#, line continuation characters are
+-- recognised. In a line continuation, the newline character is
+-- preserved, but the backslash is not.
+linesCpp :: String -> [String]
+linesCpp [] = []
+linesCpp (x:xs) | x=='#' = tok Cpp ['#'] xs
+ | otherwise = tok Haskell [] (x:xs)
+ where
+ tok Cpp acc ('\\':'\n':ys) = tok Cpp ('\n':acc) ys
+ tok _ acc ('\n':'#':ys) = reverse acc: tok Cpp ['#'] ys
+ tok _ acc ('\n':ys) = reverse acc: tok Haskell [] ys
+ tok _ acc [] = reverse acc: []
+ tok mode acc (y:ys) = tok mode (y:acc) ys
+
+-- | Put back the line-continuation characters.
+reslash :: String -> String
+reslash ('\n':xs) = '\\':'\n':reslash xs
+reslash (x:xs) = x: reslash xs
+reslash [] = []
+
+----
+-- | Submodes are required to deal correctly with nesting of lexical
+-- structures.
+data SubMode = Any | Pred (Char->Bool) (Posn->String->WordStyle)
+ | String Char | LineComment | NestComment Int
+ | CComment
+
+-- | Each token is classified as one of Ident, Other, or Cmd:
+-- * Ident is a word that could potentially match a macro name.
+-- * Cmd is a complete cpp directive (\#define etc).
+-- * Other is anything else.
+data WordStyle = Ident Posn String | Other String | Cmd (Maybe HashDefine)
+ deriving (Eq,Show)
+other :: Posn -> String -> WordStyle
+other _ s = Other s
+
+deWordStyle :: WordStyle -> String
+deWordStyle (Ident _ i) = i
+deWordStyle (Other i) = i
+deWordStyle (Cmd _) = "\n"
+
+-- | tokenise is, broadly-speaking, Prelude.words, except that:
+-- * the input is already divided into lines
+-- * each word-like "token" is categorised as one of {Ident,Other,Cmd}
+-- * \#define's are parsed and returned out-of-band using the Cmd variant
+-- * All whitespace is preserved intact as tokens.
+-- * C-comments are converted to white-space (depending on first param)
+-- * Parens and commas are tokens in their own right.
+-- * Any cpp line continuations are respected.
+-- No errors can be raised.
+-- The inverse of tokenise is (concatMap deWordStyle).
+tokenise :: Bool -> Bool -> Bool -> [(Posn,String)] -> [WordStyle]
+tokenise ___ [] = []
+tokenise strip ansi lang ((pos,str):pos_strs) =
+ (if lang then haskell else plaintext) Any [] pos pos_strs str
+ where
+ -- rules to lex Haskell
+ haskell :: SubMode -> String -> Posn -> [(Posn,String)]
+ -> String -> [WordStyle]
+ haskell Any acc p ls ('\n':'#':xs) = emit acc $ -- emit "\n" $
+ cpp Any haskell [] [] p ls xs
+ -- warning: non-maximal munch on comment
+ haskell Any acc p ls ('-':'-':xs) = emit acc $
+ haskell LineComment "--" p ls xs
+ haskell Any acc p ls ('{':'-':xs) = emit acc $
+ haskell (NestComment 0) "-{" p ls xs
+ haskell Any acc p ls ('/':'*':xs)|strip = emit acc $
+ haskell CComment " " p ls xs
+ haskell Any acc p ls ('"':xs) = emit acc $
+ haskell (String '"') ['"'] p ls xs
+ haskell Any acc p ls ('\'':xs) = emit acc $
+ haskell (String '\'') "'" p ls xs
+ haskell Any acc p ls (x:xs) | single x = emit acc $ emit [x] $
+ haskell Any [] p ls xs
+ haskell Any acc p ls (x:xs) | space x = emit acc $
+ haskell (Pred space other) [x]
+ p ls xs
+ haskell Any acc p ls (x:xs) | symbol x = emit acc $
+ haskell (Pred symbol other) [x]
+ p ls xs
+ -- haskell Any [] p ls (x:xs) | ident0 x = id $
+ haskell Any acc p ls (x:xs) | ident0 x = emit acc $
+ haskell (Pred ident1 Ident) [x]
+ p ls xs
+ haskell Any acc p ls (x:xs) = haskell Any (x:acc) p ls xs
+
+ haskell pre@(Pred pred ws) acc p ls (x:xs)
+ | pred x = haskell pre (x:acc) p ls xs
+ haskell (Pred _ ws) acc p ls xs = ws p (reverse acc):
+ haskell Any [] p ls xs
+ haskell (String c) acc p ls ('\\':x:xs)
+ | x=='\\' = haskell (String c) ('\\':'\\':acc) p ls xs
+ | x==c = haskell (String c) (c:'\\':acc) p ls xs
+ haskell (String c) acc p ls (x:xs)
+ | x==c = emit (c:acc) $ haskell Any [] p ls xs
+ | otherwise = haskell (String c) (x:acc) p ls xs
+ haskell LineComment acc p ls xs@('\n':_) = emit acc $ haskell Any [] p ls xs
+ haskell LineComment acc p ls (x:xs) = haskell LineComment (x:acc) p ls xs
+ haskell (NestComment n) acc p ls ('{':'-':xs)
+ = haskell (NestComment (n+1))
+ ("-{"++acc) p ls xs
+ haskell (NestComment 0) acc p ls ('-':'}':xs)
+ = emit ("}-"++acc) $ haskell Any [] p ls xs
+ haskell (NestComment n) acc p ls ('-':'}':xs)
+ = haskell (NestComment (n-1))
+ ("}-"++acc) p ls xs
+ haskell (NestComment n) acc p ls (x:xs) = haskell (NestComment n) (x:acc)
+ p ls xs
+ haskell CComment acc p ls ('*':'/':xs) = emit (" "++acc) $
+ haskell Any [] p ls xs
+ haskell CComment acc p ls (_:xs) = haskell CComment (' ':acc) p ls xs
+ haskell mode acc _ ((p,l):ls) [] = haskell mode acc p ls ('\n':l)
+ haskell _ acc _ [] [] = emit acc $ []
+
+ -- rules to lex Cpp
+ cpp :: SubMode -> (SubMode -> String -> Posn -> [(Posn,String)]
+ -> String -> [WordStyle])
+ -> String -> [String] -> Posn -> [(Posn,String)]
+ -> String -> [WordStyle]
+ cpp mode next word line pos remaining input =
+ lexcpp mode word line remaining input
+ where
+ lexcpp Any w l ls ('/':'*':xs) = lexcpp (NestComment 0) "" (w*/*l) ls xs
+ lexcpp Any w l ls ('/':'/':xs) = lexcpp LineComment " " (w*/*l) ls xs
+ lexcpp Any w l ((p,l'):ls) ('\\':[]) = cpp Any next [] ("\n":w*/*l) p ls l'
+ lexcpp Any w l ls ('\\':'\n':xs) = lexcpp Any [] ("\n":w*/*l) ls xs
+ lexcpp Any w l ls xs@('\n':_) = Cmd (parseHashDefine ansi
+ (reverse (w*/*l))):
+ next Any [] pos ls xs
+ -- lexcpp Any w l ls ('"':xs) = lexcpp (String '"') ['"'] (w*/*l) ls xs
+ -- lexcpp Any w l ls ('\'':xs) = lexcpp (String '\'') "'" (w*/*l) ls xs
+ lexcpp Any w l ls ('"':xs) = lexcpp Any [] ("\"":(w*/*l)) ls xs
+ lexcpp Any w l ls ('\'':xs) = lexcpp Any [] ("'": (w*/*l)) ls xs
+ lexcpp Any [] l ls (x:xs)
+ | ident0 x = lexcpp (Pred ident1 Ident) [x] l ls xs
+ -- lexcpp Any w l ls (x:xs) | ident0 x = lexcpp (Pred ident1 Ident) [x] (w*/*l) ls xs
+ lexcpp Any w l ls (x:xs)
+ | single x = lexcpp Any [] ([x]:w*/*l) ls xs
+ | space x = lexcpp (Pred space other) [x] (w*/*l) ls xs
+ | symbol x = lexcpp (Pred symbol other) [x] (w*/*l) ls xs
+ | otherwise = lexcpp Any (x:w) l ls xs
+ lexcpp pre@(Pred pred _) w l ls (x:xs)
+ | pred x = lexcpp pre (x:w) l ls xs
+ lexcpp (Pred __) w l ls xs = lexcpp Any [] (w*/*l) ls xs
+ lexcpp (String c) w l ls ('\\':x:xs)
+ | x=='\\' = lexcpp (String c) ('\\':'\\':w) l ls xs
+ | x==c = lexcpp (String c) (c:'\\':w) l ls xs
+ lexcpp (String c) w l ls (x:xs)
+ | x==c = lexcpp Any [] ((c:w)*/*l) ls xs
+ | otherwise = lexcpp (String c) (x:w) l ls xs
+ lexcpp LineComment w l ((p,l'):ls) ('\\':[])
+ = cpp LineComment next [] (('\n':w)*/*l) pos ls l'
+ lexcpp LineComment w l ls ('\\':'\n':xs)
+ = lexcpp LineComment [] (('\n':w)*/*l) ls xs
+ lexcpp LineComment w l ls xs@('\n':_) = lexcpp Any w l ls xs
+ lexcpp LineComment w l ls (_:xs) = lexcpp LineComment (' ':w) l ls xs
+ lexcpp (NestComment _) w l ls ('*':'/':xs)
+ = lexcpp Any [] (w*/*l) ls xs
+ lexcpp (NestComment n) w l ls (_:xs) = lexcpp (NestComment n) (' ':w) l
+ ls xs
+ lexcpp mode w l ((p,l'):ls) [] = cpp mode next w l p ls ('\n':l')
+ lexcpp ___ [] [] = []
+
+ -- rules to lex non-Haskell, non-cpp text
+ plaintext :: SubMode -> String -> Posn -> [(Posn,String)]
+ -> String -> [WordStyle]
+ plaintext Any acc p ls ('\n':'#':xs) = emit acc $ -- emit "\n" $
+ cpp Any plaintext [] [] p ls xs
+ plaintext Any acc p ls ('/':'*':xs)|strip = emit acc $
+ plaintext CComment " " p ls xs
+ plaintext Any acc p ls (x:xs) | single x = emit acc $ emit [x] $
+ plaintext Any [] p ls xs
+ plaintext Any acc p ls (x:xs) | space x = emit acc $
+ plaintext (Pred space other) [x]
+ p ls xs
+ plaintext Any acc p ls (x:xs) | ident0 x = emit acc $
+ plaintext (Pred ident1 Ident) [x]
+ p ls xs
+ plaintext Any acc p ls (x:xs) = plaintext Any (x:acc) p ls xs
+ plaintext pre@(Pred pred ws) acc p ls (x:xs)
+ | pred x = plaintext pre (x:acc) p ls xs
+ plaintext (Pred _ ws) acc p ls xs = ws p (reverse acc):
+ plaintext Any [] p ls xs
+ plaintext CComment acc p ls ('*':'/':xs) = emit (" "++acc) $
+ plaintext Any [] p ls xs
+ plaintext CComment acc p ls (_:xs) = plaintext CComment (' ':acc) p ls xs
+ plaintext mode acc _ ((p,l):ls) [] = plaintext mode acc p ls ('\n':l)
+ plaintext _ acc _ [] [] = emit acc $ []
+
+ -- predicates for lexing Haskell.
+ ident0 x = isAlpha x || x `elem` "_`"
+ ident1 x = isAlphaNum x || x `elem` "'_`"
+ symbol x = x `elem` ":!#$%&*+./<=>?@\\^|-~"
+ single x = x `elem` "(),[];{}"
+ space x = x `elem` " \t"
+ -- emit a token (if there is one) from the accumulator
+ emit "" = id
+ emit xs = (Other (reverse xs):)
+ -- add a reversed word to the accumulator
+ "" */* l = l
+ w */* l = reverse w : l
+ -- help out broken Haskell compilers which need balanced numbers of C
+ -- comments in order to do import chasing :-) -----> */*
+
+
+-- | Parse a possible macro call, returning argument list and remaining input
+parseMacroCall :: Posn -> [WordStyle] -> Maybe ([[WordStyle]],[WordStyle])
+parseMacroCall p = call . skip
+ where
+ skip (Other x:xs) | all isSpace x = skip xs
+ skip xss = xss
+ call (Other "(":xs) = (args (0::Int) [] [] . skip) xs
+ call _ = Nothing
+ args 0 w acc ( Other ")" :xs) = Just (reverse (addone w acc), xs)
+ args 0 w acc ( Other "," :xs) = args 0 [] (addone w acc) (skip xs)
+ args n w acc (x@(Other "("):xs) = args (n+1) (x:w) acc xs
+ args n w acc (x@(Other ")"):xs) = args (n-1) (x:w) acc xs
+ args n w acc ( Ident _ v :xs) = args n (Ident p v:w) acc xs
+ args n w acc (x@(Other _) :xs) = args n (x:w) acc xs
+ args ____ = Nothing
+ addone w acc = reverse (skip w): acc
+
+
-- | Part of this code is from "Report on the Programming Language Haskell",
+-- version 1.2, appendix C.
+module Language.Preprocessor.Unlit (unlit) where
+
+import Char
+
+data Classified = Program String | Blank | Comment
+ | Include Int String | Pre String
+
+classify :: [String] -> [Classified]
+classify [] = []
+classify (('\\':x):xs) | x == "begin{code}" = Blank : allProg xs
+ where allProg [] = [] -- Should give an error message,
+ -- but I have no good position information.
+ allProg (('\\':x):xs) | x == "end{code}" = Blank : classify xs
+ allProg (x:xs) = Program x:allProg xs
+classify (('>':x):xs) = Program (' ':x) : classify xs
+classify (('#':x):xs) = (case words x of
+ (line:file:_) | all isDigit line
+ -> Include (read line) file
+ _ -> Pre x
+ ) : classify xs
+classify (x:xs) | all isSpace x = Blank:classify xs
+classify (x:xs) = Comment:classify xs
+
+unclassify :: Classified -> String
+unclassify (Program s) = s
+unclassify (Pre s) = '#':s
+unclassify (Include i f) = '#':' ':show i ++ ' ':f
+unclassify Blank = ""
+unclassify Comment = ""
+
+-- | 'unlit' takes a filename (for error reports), and transforms the
+-- given string, to eliminate the literate comments from the program text.
+unlit :: FilePath -> String -> String
+unlit file lhs = (unlines
+ . map unclassify
+ . adjacent file (0::Int) Blank
+ . classify) (inlines lhs)
+
+adjacent :: FilePath -> Int -> Classified -> [Classified] -> [Classified]
+adjacent file 0 _ (x :xs) = x : adjacent file 1 x xs -- force evaluation of line number
+adjacent file n y@(Program _) (x@Comment :xs) = error (message file n "program" "comment")
+adjacent file n y@(Program _) (x@(Include i f):xs) = x: adjacent f i y xs
+adjacent file n y@(Program _) (x@(Pre _) :xs) = x: adjacent file (n+1) y xs
+adjacent file n y@Comment (x@(Program _) :xs) = error (message file n "comment" "program")
+adjacent file n y@Comment (x@(Include i f):xs) = x: adjacent f i y xs
+adjacent file n y@Comment (x@(Pre _) :xs) = x: adjacent file (n+1) y xs
+adjacent file n y@Blank (x@(Include i f):xs) = x: adjacent f i y xs
+adjacent file n y@Blank (x@(Pre _) :xs) = x: adjacent file (n+1) y xs
+adjacent file n _ (x@next :xs) = x: adjacent file (n+1) x xs
+adjacent file n _ [] = []
+
+message :: String -> Int -> String -> String -> String
+message "\"\"" n p c = "Line "++show n++": "++p++ " line before "++c++" line.\n"
+message [] n p c = "Line "++show n++": "++p++ " line before "++c++" line.\n"
+message file n p c = "In file " ++ file ++ " at line "++show n++": "++p++ " line before "++c++" line.\n"
+
+
+-- Re-implementation of 'lines', for better efficiency (but decreased laziness).
+-- Also, importantly, accepts non-standard DOS and Mac line ending characters.
+inlines :: String -> [String]
+inlines s = lines' s id
+ where
+ lines' [] acc = [acc []]
+ lines' ('\^M':'\n':s) acc = acc [] : lines' s id -- DOS
+ lines' ('\^M':s) acc = acc [] : lines' s id -- MacOS
+ lines' ('\n':s) acc = acc [] : lines' s id -- Unix
+ lines' (c:s) acc = lines' s (acc . (c:))
+
+
Graham Hutton Erik Meijer
+ University of Nottingham University of Utrecht
+
This Haskell script defines a library of parser combinators, and is
+ taken from sections 1-6 of our article Monadic Parser Combinators.
+ Some changes to the library have been made in the move from Gofer
+ to Haskell:
+
Do notation is used in place of monad comprehension notation;
+
The parser datatype is defined using newtype, to avoid the overhead
+ of tagging and untagging parsers with the P constructor.
+
-----------------------------------------------------------------------------
+-- |
+-- Module : ParseLib
+-- Copyright : ...
+-- Copyright : Graham Hutton (University of Nottingham), Erik Meijer (University of Utrecht)
+--
+-- Maintainer : Malcolm Wallace <Malcolm.Wallace@cs.york.ac.uk>
+-- Stability : Stable
+-- Portability : All
+--
+-- A LIBRARY OF MONADIC PARSER COMBINATORS
+--
+-- 29th July 1996
+--
+-- Graham Hutton Erik Meijer
+-- University of Nottingham University of Utrecht
+--
+-- This Haskell script defines a library of parser combinators, and is
+-- taken from sections 1-6 of our article "Monadic Parser Combinators".
+-- Some changes to the library have been made in the move from Gofer
+-- to Haskell:
+--
+-- * Do notation is used in place of monad comprehension notation;
+--
+-- * The parser datatype is defined using "newtype", to avoid the overhead
+-- of tagging and untagging parsers with the P constructor.
+-----------------------------------------------------------------------------
+
+
+module Text.ParserCombinators.HuttonMeijer
+ (Parser(..), item, first, papply, (+++), sat, {-tok,-} many, many1,
+ sepby, sepby1, chainl,
+ chainl1, chainr, chainr1, ops, bracket, char, digit, lower, upper,
+ letter, alphanum, string, ident, nat, int, spaces, comment, junk,
+ skip, token, natural, integer, symbol, identifier) where
+
+import Char
+import Monad
+
+infixr 5 +++
+
+type Token = Char
+
+---------------------------------------------------------
+-- | The parser monad
+
+newtype Parser a = P ([Token] -> [(a,[Token])])
+
+instance Functor Parser where
+ -- map :: (a -> b) -> (Parser a -> Parser b)
+ fmap f (P p) = P (\inp -> [(f v, out) | (v,out) <- p inp])
+
+instance Monad Parser where
+ -- return :: a -> Parser a
+ return v = P (\inp -> [(v,inp)])
+
+ -- >>= :: Parser a -> (a -> Parser b) -> Parser b
+ (P p) >>= f = P (\inp -> concat [papply (f v) out | (v,out) <- p inp])
+
+ -- fail :: String -> Parser a
+ fail _ = P (\_ -> [])
+
+instance MonadPlus Parser where
+ -- mzero :: Parser a
+ mzero = P (\_ -> [])
+
+ -- mplus :: Parser a -> Parser a -> Parser a
+ (P p) `mplus` (P q) = P (\inp -> (p inp ++ q inp))
+
+-- ------------------------------------------------------------
+-- * Other primitive parser combinators
+-- ------------------------------------------------------------
+
+item :: Parser Token
+item = P (\inp -> case inp of
+ [] -> []
+ (x:xs) -> [(x,xs)])
+
+first :: Parser a -> Parser a
+first (P p) = P (\inp -> case p inp of
+ [] -> []
+ (x:_) -> [x])
+
+papply :: Parser a -> [Token] -> [(a,[Token])]
+papply (P p) inp = p inp
+
+-- ------------------------------------------------------------
+-- * Derived combinators
+-- ------------------------------------------------------------
+
+(+++) :: Parser a -> Parser a -> Parser a
+p +++ q = first (p `mplus` q)
+
+sat :: (Token -> Bool) -> Parser Token
+sat p = do {x <- item; if p x then return x else mzero}
+
+--tok :: Token -> Parser Token
+--tok t = do {x <- item; if t==snd x then return t else mzero}
+
+many :: Parser a -> Parser [a]
+many p = many1 p +++ return []
+--many p = force (many1 p +++ return [])
+
+many1 :: Parser a -> Parser [a]
+many1 p = do {x <- p; xs <- many p; return (x:xs)}
+
+sepby :: Parser a -> Parser b -> Parser [a]
+p `sepby` sep = (p `sepby1` sep) +++ return []
+
+sepby1 :: Parser a -> Parser b -> Parser [a]
+p `sepby1` sep = do {x <- p; xs <- many (do {sep; p}); return (x:xs)}
+
+chainl :: Parser a -> Parser (a -> a -> a) -> a -> Parser a
+chainl p op v = (p `chainl1` op) +++ return v
+
+chainl1 :: Parser a -> Parser (a -> a -> a) -> Parser a
+p `chainl1` op = do {x <- p; rest x}
+ where
+ rest x = do {f <- op; y <- p; rest (f x y)}
+ +++ return x
+
+chainr :: Parser a -> Parser (a -> a -> a) -> a -> Parser a
+chainr p op v = (p `chainr1` op) +++ return v
+
+chainr1 :: Parser a -> Parser (a -> a -> a) -> Parser a
+p `chainr1` op = do {x <- p; rest x}
+ where
+ rest x = do {f <- op; y <- p `chainr1` op; return (f x y)}
+ +++ return x
+
+ops :: [(Parser a, b)] -> Parser b
+ops xs = foldr1 (+++) [do {p; return op} | (p,op) <- xs]
+
+bracket :: Parser a -> Parser b -> Parser c -> Parser b
+bracket open p close = do {open; x <- p; close; return x}
+
+-- ------------------------------------------------------------
+-- * Useful parsers
+-- ------------------------------------------------------------
+
+char :: Char -> Parser Char
+char x = sat (\y -> x == y)
+
+digit :: Parser Char
+digit = sat isDigit
+
+lower :: Parser Char
+lower = sat isLower
+
+upper :: Parser Char
+upper = sat isUpper
+
+letter :: Parser Char
+letter = sat isAlpha
+
+alphanum :: Parser Char
+alphanum = sat isAlphaNum +++ char '_'
+
+string :: String -> Parser String
+string "" = return ""
+string (x:xs) = do {char x; string xs; return (x:xs)}
+
+ident :: Parser String
+ident = do {x <- lower; xs <- many alphanum; return (x:xs)}
+
+nat :: Parser Int
+nat = do {x <- digit; return (fromEnum x - fromEnum '0')} `chainl1` return op
+ where
+ m `op` n = 10*m + n
+
+int :: Parser Int
+int = do {char '-'; n <- nat; return (-n)} +++ nat
+
+-- ------------------------------------------------------------
+-- * Lexical combinators
+-- ------------------------------------------------------------
+
+spaces :: Parser ()
+spaces = do {many1 (sat isSpace); return ()}
+
+comment :: Parser ()
+--comment = do {string "--"; many (sat (\x -> x /= '\n')); return ()}
+--comment = do
+-- _ <- string "--"
+-- _ <- many (sat (\x -> x /= '\n'))
+-- return ()
+comment = do
+ bracket (string "/*") (many item) (string "*/")
+ return ()
+
+junk :: Parser ()
+junk = do {many (spaces +++ comment); return ()}
+
+skip :: Parser a -> Parser a
+skip p = do {junk; p}
+
+token :: Parser a -> Parser a
+token p = do {v <- p; junk; return v}
+
+-- ------------------------------------------------------------
+-- * Token parsers
+-- ------------------------------------------------------------
+
+natural :: Parser Int
+natural = token nat
+
+integer :: Parser Int
+integer = token int
+
+symbol :: String -> Parser String
+symbol xs = token (string xs)
+
+identifier :: [String] -> Parser String
+identifier ks = token (do {x <- ident;
+ if not (elem x ks) then return x
+ else return mzero})
+
+------------------------------------------------------------------------------
+
{-
+-- The main program wrapper for cpphs, a simple C pre-processor
+-- written in Haskell.
+
+-- Author: Malcolm Wallace, 2004
+-- This file is licensed under the GPL. Note however, that all other
+-- modules used by it are either distributed under the LGPL, or are Haskell'98.
+--
+-- Thus, when compiled as a standalone executable, this program will fall
+-- under the GPL.
+-}
+module Main where
+
+import System ( getArgs, getProgName, exitWith, ExitCode(..) )
+import Maybe
+import Language.Preprocessor.Cpphs ( runCpphs, CpphsOptions(..), parseOptions )
+import IO ( stdout, IOMode(WriteMode), openFile, hPutStr, hFlush, hClose )
+import Monad ( when )
+import List ( isPrefixOf )
+
+version :: String
+version = "1.5"
+
+main :: IO ()
+main = do
+ args <- getArgs
+ args <- return $ if "--cpp" `elem` args then convertArgs args else args
+
+ prog <- getProgName
+ when ("--version" `elem` args)
+ (do putStrLn (prog++" "++version)
+ exitWith ExitSuccess)
+ when ("--help" `elem` args)
+ (do putStrLn ("Usage: "++prog
+ ++" [file ...] [ -Dsym | -Dsym=val | -Ipath ]* [-Ofile]\n"
+ ++"\t\t[--nomacro] [--noline] [--pragma] [--text]\n"
+ ++"\t\t[--strip] [--hashes] [--layout] [--unlit]\n"
+ ++"\t\t[ --cpp std-cpp-options ]")
+ exitWith ExitSuccess)
+
+ let parsedArgs = parseOptions args
+ options = fromRight parsedArgs
+ ins = infiles options
+ outs = outfiles options
+ out = listToMaybe outs
+
+ when (isLeft parsedArgs)
+ (do putStrLn $ "Unknown option "++fromLeft parsedArgs
+ ++", for valid options try "++prog++" --help\n"
+ exitWith (ExitFailure 1))
+ when (length outs > 1)
+ (do putStrLn $ "At most one output file (-O) can be specified"
+ exitWith (ExitFailure 2))
+ if null ins then execute options out Nothing
+ else mapM_ (execute options out) (map Just ins)
+
+-- | Execute the preprocessor.
+-- If the filepath is Nothing then default to stdout\/stdin as appropriate.
+execute :: CpphsOptions -> Maybe FilePath -> Maybe FilePath -> IO ()
+execute opts ofile infile =
+ let (filename, readIt) = case infile of
+ Just x -> (x, readFile x)
+ Nothing -> ("stdin", getContents)
+ output Nothing x = do putStr x; hFlush stdout
+ output (Just f) x = writeFile f x
+ indo contents <- readIt
+ output ofile (runCpphs opts filename contents)
+
+isLeft (Left _) = True
+isLeft _ = False
+
+fromLeft (Left x) = x
+fromRight (Right x) = x
+
+-- | Convert commandline options to remain compatible with cpp.
+-- Based on a shell script cpphs.compat
+data ConvertArgs = ConvertArgs { traditional, strip :: Bool
+ , infile, outfile :: String }
+
+convertArgs :: [String] -> [String]
+convertArgs xs = f (ConvertArgs False True "-" "-") xs
+ where
+ flg = "DUI"
+
+ f e (['-',r]:x:xs) | r `elem` flg = ('-':r:x) : f e xs
+ f e (x@('-':r:_):xs) | r `elem` flg = x : f e xs
+ f e ("-o":x:xs) = ('-':'O':x) : f e xs
+ f e (('-':'o':x):xs) = ('-':'O':drop 2 x) : f e xs
+ f e (('-':x):xs) | "ansi" `isPrefixOf` x = f e{traditional=False} xs
+ | "traditional" `isPrefixOf` x = f e{traditional=True} xs
+ | "std" `isPrefixOf` x = f e xs -- ignore language spec
+ f e ("-x":x:xs) = f e xs -- ignore langauge spec
+ f e ("-include":x:xs) = x : f e xs
+ f e ("-P":xs) = "--noline" : f e xs
+ f e (x:xs) | x == "-C" || x == "-CC" = f e{strip=False} xs
+ f e ("-A":x:xs) = f e xs -- strip assertions
+ f e ("--help":xs) = "--help" : f e xs
+ f e ("--version":xs) = "--version" : f e xs
+ f e ("-version":xs) = "--version" : f e xs
+ f e (('-':x):xs) = f e xs -- strip all other flags
+ f e (x:xs) = f (if infile e == "-" then e{infile=x} else e{outfile=x}) xs
+
+ f e [] = ["--hashes" | not (traditional e)] ++
+ ["--strip" | strip e] ++
+ [infile e] ++
+ ["-O" ++ outfile e | outfile e /= "-"]
+
+
+
diff --git a/docs/cpphs/minus.gif b/docs/cpphs/minus.gif
new file mode 100644
Binary files /dev/null and b/docs/cpphs/minus.gif differ
diff --git a/docs/cpphs/plus.gif b/docs/cpphs/plus.gif
new file mode 100644
Binary files /dev/null and b/docs/cpphs/plus.gif differ
diff --git a/docs/index.html b/docs/index.html
--- a/docs/index.html
+++ b/docs/index.html
@@ -58,13 +58,12 @@
conditional compilation only (--nomacro),
and full macro-expansion (default).
-In --nomacro mode, cpphs performs only conditional
-compilation actions, namely #include's, #if's,
-and #ifdef's are processed according to text-replacement
-definitions (both command-line and internal), but no parameterised
-macro expansion is performed. In full compatibility mode (the
-default), textual replacements and macro expansions are also processed
-in the remaining body of non-cpp text.
+In --nomacro mode, cpphs performs only conditional compilation
+actions, namely #include's, #if's, and
+#ifdef's are processed according to text-replacement
+definitions and macro expansions (both command-line and internal).
+In full compatibility mode (the default), textual replacements and macro
+expansions are also processed in the remaining body of non-cpp text.
Added a "--cpp" option for drop-in compatibility with standard cpp.
- It causes cpphs to accept standard cpp flags and translate
- them to cpphs equivalents. Compatibility options include: -o, -ansi,
- -traditional, -stdc, -x, -include, -P, -C, -CC, -A. The file
- behaviour is different too - if two filenames are given on the
- commandline, then the second is treated as the output location.
-
Fixed a corner-case bug in evaluating chained and overlapping #ifdefs.
+
Fixed some more obscure corner cases, involving parameterised macro
+ expansion within conditionals e.g. #if FOO(BAR,QUUX)
+
Internal refactoring, affecting parts of the library API.
@@ -209,6 +211,34 @@
Older versions:
+cpphs-1.4, release date 2007.04.17
+By HTTP:
+.tar.gz,
+.zip.
+
+
Added a "--pragma" option to retain #pragma in the output.
+
Fixed a number of obscure corner cases involving the interaction of
+ multiple features e.g. foo##__LINE__.
+
Added a "--cpp" option for drop-in compatibility with standard cpp.
+ It causes cpphs to accept standard cpp flags and translate
+ them to cpphs equivalents. Compatibility options include: -o, -ansi,
+ -traditional, -stdc, -x, -include, -P, -C, -CC, -A. The file
+ behaviour is different too - if two filenames are given on the
+ commandline, then the second is treated as the output location.
+
Fixed a corner-case bug in evaluating chained and overlapping #ifdefs.
+
+
+
cpphs-1.2, release date 2006.05.04
By HTTP:
.tar.gz,
@@ -466,7 +496,7 @@
Malcolm.Wallace@cs.york.ac.uk
-
Instances