----------------------------------------------------------------------------- +-- | +-- Module : Language.Preprocessor.Cpphs +-- Copyright : 2000-2006 Malcolm Wallace +-- Licence : LGPL +-- +-- Maintainer : Malcolm Wallace <Malcolm.Wallace@cs.york.ac.uk> +-- Stability : experimental +-- Portability : All +-- +-- Include the interface that is exported +----------------------------------------------------------------------------- + +module Language.Preprocessor.Cpphs + ( runCpphs, cppIfdef, macroPass, CpphsOptions(..), BoolOptions(..) + , parseOptions, defaultCpphsOptions, defaultBoolOptions + ) where + +import Language.Preprocessor.Cpphs.CppIfdef(cppIfdef) +import Language.Preprocessor.Cpphs.MacroPass(macroPass) +import Language.Preprocessor.Cpphs.RunCpphs(runCpphs) +import Language.Preprocessor.Cpphs.Options + (CpphsOptions(..), BoolOptions(..), parseOptions + ,defaultCpphsOptions,defaultBoolOptions)+ diff --git a/docs/cpphs/Language/Preprocessor/Cpphs/CppIfdef.html b/docs/cpphs/Language/Preprocessor/Cpphs/CppIfdef.html --- a/docs/cpphs/Language/Preprocessor/Cpphs/CppIfdef.html +++ b/docs/cpphs/Language/Preprocessor/Cpphs/CppIfdef.html @@ -1,267 +1,271 @@ -
----------------------------------------------------------------------------- --- | --- Module : CppIfdef --- Copyright : 1999-2004 Malcolm Wallace --- Licence : LGPL --- --- Maintainer : Malcolm Wallace <Malcolm.Wallace@cs.york.ac.uk> --- Stability : experimental --- Portability : All --- --- Perform a cpp.first-pass, gathering \#define's and evaluating \#ifdef's. --- and \#include's. ------------------------------------------------------------------------------ - -module Language.Preprocessor.Cpphs.CppIfdef - ( cppIfdef -- :: FilePath -> [(String,String)] -> [String] -> Options - -- -> String -> [(Posn,String)] - ) where - - -import Language.Preprocessor.Cpphs.SymTab -import Text.ParserCombinators.HuttonMeijer --- import HashDefine -import Language.Preprocessor.Cpphs.Position (Posn,newfile,newline,newlines - ,cppline,newpos) -import Language.Preprocessor.Cpphs.ReadFirst (readFirst) -import Language.Preprocessor.Cpphs.Tokenise (linesCpp,reslash) -import Language.Preprocessor.Cpphs.Options (BoolOptions(..)) -import Language.Preprocessor.Cpphs.HashDefine(HashDefine(..),parseHashDefine - ,expandMacro) -import Language.Preprocessor.Cpphs.MacroPass (preDefine,defineMacro) -import Char (isDigit) -import Numeric (readHex,readOct,readDec) -import System.IO.Unsafe (unsafePerformIO) -import IO (hPutStrLn,stderr) - - --- | Run a first pass of cpp, evaluating \#ifdef's and processing \#include's, --- whilst taking account of \#define's and \#undef's as we encounter them. -cppIfdef :: FilePath -- ^ File for error reports - -> [(String,String)] -- ^ Pre-defined symbols and their values - -> [String] -- ^ Search path for \#includes - -> BoolOptions -- ^ Options controlling output style - -> String -- ^ The input file content - -> [(Posn,String)] -- ^ The file after processing (in lines) -cppIfdef fp syms search options = - cpp posn defs search options Keep . (cppline posn:) . linesCpp - where - posn = newfile fp - defs = preDefine options syms --- Previous versions had a very simple symbol table mapping strings --- to strings. Now the #ifdef pass uses a more elaborate table, in --- particular to deal with parameterised macros in conditionals. - - --- | Internal state for whether lines are being kept or dropped. --- In @Drop n b@, @n@ is the depth of nesting, @b@ is whether --- we have already succeeded in keeping some lines in a chain of --- @elif@'s -data KeepState = Keep | Drop Int Bool - --- | 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 _ _ _ _ _ [] = [] - -cpp p syms path options Keep (l@('#':x):xs) = - let ws = words x - cmd = head ws - line = tail ws - sym = head (tail ws) - rest = tail (tail ws) - def = defineMacro options (sym++" "++ maybe "1" id (un rest)) - un v = if null v then Nothing else Just (unwords v) - keepIf p = if p then Keep else (Drop 1 False) - skipn syms' ud xs' = - let n = 1 + length (filter (=='\n') l) in - (if macros options then ((p,reslash l):) - else (replicate n (p,"") ++)) $ - cpp (newlines n p) syms' path options ud xs' - in case cmd of - "define" -> skipn (insertST def syms) Keep xs - "undef" -> skipn (deleteST sym syms) Keep xs - "ifndef" -> skipn syms (keepIf (not (definedST sym syms))) xs - "ifdef" -> skipn syms (keepIf (definedST sym syms)) xs - "if" -> skipn syms (keepIf (gatherDefined p syms (unwords line))) xs - "else" -> skipn syms (Drop 1 False) xs - "elif" -> skipn syms (Drop 1 True) xs - "endif" -> skipn syms Keep xs - "pragma" -> skipn syms Keep xs - ('!':_) -> skipn syms 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 Keep xs - else skipn syms Keep xs - "error" -> error (l++"\nin "++show p) - "line" | all isDigit sym - -> (if locations options then ((p,l):) else id) $ - cpp (newpos (read sym) (un rest) p) - syms path options Keep xs - n | all isDigit n - -> (if locations options then ((p,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) - -cpp p syms path options (Drop n b) (('#':x):xs) = - let ws = words x - cmd = head ws - delse | n==1 && b = Drop 1 b - | n==1 = Keep - | otherwise = Drop n b - dend | n==1 = Keep - | otherwise = Drop (n-1) b - delif s | n==1 && not b && gatherDefined p syms s - = Keep - | 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' - in - if cmd == "ifndef" || - cmd == "if" || - cmd == "ifdef" then skipn (Drop (n+1) b) xs - else if cmd == "elif" then skipn (delif (unwords (tail ws))) xs - else if cmd == "else" then skipn delse xs - else if cmd == "endif" then skipn dend xs - else skipn (Drop n b) xs - -- define, undef, include, error, warning, pragma, line - -cpp p syms path options Keep (x:xs) = - let p' = newline p in seq p' $ - (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 - - ----- -gatherDefined :: Posn -> SymTab HashDefine -> String -> Bool -gatherDefined p st inp = - case papply (parseBoolExp st) inp of - [] -> error ("Cannot parse #if directive in file "++show p) - [(b,_)] -> b - _ -> error ("Ambiguous parse for #if directive in file "++show p) - -parseBoolExp :: SymTab HashDefine -> Parser Bool -parseBoolExp st = - do a <- parseExp1 st - skip (string "||") - b <- first (skip (parseBoolExp st)) - return (a || b) - +++ - parseExp1 st - -parseExp1 :: SymTab HashDefine -> Parser Bool -parseExp1 st = - do a <- parseExp0 st - skip (string "&&") - b <- first (skip (parseExp1 st)) - return (a && b) - +++ - parseExp0 st - -parseExp0 :: SymTab HashDefine -> Parser Bool -parseExp0 st = - do skip (string "defined") - sym <- parens parseSym - return (definedST sym st) - +++ - do parens (parseBoolExp st) - +++ - do skip (char '!') - a <- parseExp0 st - return (not a) - +++ - do sym1 <- parseSymOrCall st - op <- parseOp st - sym2 <- parseSymOrCall st - return (op (safeRead sym1) (safeRead sym2)) - +++ - do sym <- parseSymOrCall st - case safeRead sym of - 0 -> return False - _ -> return True - where - safeRead s = - case s of - '0':'x':s' -> number readHex s' - '0':'o':s' -> number readOct s' - _ -> number readDec s - number rd s = - case rd s of - [] -> 0 :: Integer - ((n,_):_) -> n :: Integer - -parseOp :: SymTab HashDefine -> Parser (Integer -> Integer -> Bool) -parseOp _ = - do skip (string ">=") - return (>=) - +++ - do skip (char '>') - return (>) - +++ - do skip (string "<=") - return (<=) - +++ - do skip (char '<') - return (<) - +++ - do skip (string "==") - return (==) - +++ - do skip (string "!=") - return (/=) - -parseSymOrCall :: SymTab HashDefine -> Parser String -parseSymOrCall st = - do sym <- skip parseSym - args <- parens (parseSymOrCall st `sepby` skip (char ',')) - return (convert sym args) - +++ - do sym <- skip parseSym - return (convert sym []) - where - convert sym args = - case lookupST sym st of - Nothing -> sym - Just (a@SymbolReplacement{}) -> recursivelyExpand st (replacement a) - Just (a@MacroExpansion{}) -> expandMacro a args False - -recursivelyExpand :: SymTab HashDefine -> String -> String -recursivelyExpand st inp = - case papply (parseSymOrCall st) inp of - [(b,_)] -> b - _ -> inp - -parseSym :: Parser String -parseSym = many1 (alphanum+++char '\''+++char '`') - -parens p = bracket (skip (char '(')) (skip p) (skip (char ')')) - --- | Determine filename in \#include -file :: SymTab HashDefine -> String -> String -file st name = - case name of - ('"':ns) -> init ns - ('<':ns) -> init ns - _ -> let ex = recursivelyExpand st name in - if ex == name then name else file st ex + + +----------------------------------------------------------------------------- +-- | +-- Module : CppIfdef +-- Copyright : 1999-2004 Malcolm Wallace +-- Licence : LGPL +-- +-- Maintainer : Malcolm Wallace <Malcolm.Wallace@cs.york.ac.uk> +-- Stability : experimental +-- Portability : All +-- +-- Perform a cpp.first-pass, gathering \#define's and evaluating \#ifdef's. +-- and \#include's. +----------------------------------------------------------------------------- + +module Language.Preprocessor.Cpphs.CppIfdef + ( cppIfdef -- :: FilePath -> [(String,String)] -> [String] -> Options + -- -> String -> [(Posn,String)] + ) where + + +import Language.Preprocessor.Cpphs.SymTab +import Text.ParserCombinators.HuttonMeijer +-- import HashDefine +import Language.Preprocessor.Cpphs.Position (Posn,newfile,newline,newlines + ,cppline,newpos) +import Language.Preprocessor.Cpphs.ReadFirst (readFirst) +import Language.Preprocessor.Cpphs.Tokenise (linesCpp,reslash) +import Language.Preprocessor.Cpphs.Options (BoolOptions(..)) +import Language.Preprocessor.Cpphs.HashDefine(HashDefine(..),parseHashDefine + ,expandMacro) +import Language.Preprocessor.Cpphs.MacroPass (preDefine,defineMacro) +import Char (isDigit) +import Numeric (readHex,readOct,readDec) +import System.IO.Unsafe (unsafePerformIO) +import IO (hPutStrLn,stderr) + + +-- | Run a first pass of cpp, evaluating \#ifdef's and processing \#include's, +-- whilst taking account of \#define's and \#undef's as we encounter them. +cppIfdef :: FilePath -- ^ File for error reports + -> [(String,String)] -- ^ Pre-defined symbols and their values + -> [String] -- ^ Search path for \#includes + -> BoolOptions -- ^ Options controlling output style + -> String -- ^ The input file content + -> [(Posn,String)] -- ^ The file after processing (in lines) +cppIfdef fp syms search options = + cpp posn defs search options Keep . (cppline posn:) . linesCpp + where + posn = newfile fp + defs = preDefine options syms +-- Previous versions had a very simple symbol table mapping strings +-- to strings. Now the #ifdef pass uses a more elaborate table, in +-- particular to deal with parameterised macros in conditionals. + + +-- | Internal state for whether lines are being kept or dropped. +-- In @Drop n b@, @n@ is the depth of nesting, @b@ is whether +-- we have already succeeded in keeping some lines in a chain of +-- @elif@'s +data KeepState = Keep | Drop Int Bool + +-- | 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 _ _ _ _ _ [] = [] + +cpp p syms path options Keep (l@('#':x):xs) = + let ws = words x + cmd = head ws + line = tail ws + sym = head (tail ws) + rest = tail (tail ws) + def = defineMacro options (sym++" "++ maybe "1" id (un rest)) + un v = if null v then Nothing else Just (unwords v) + 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,"") ++)) $ + cpp (newlines n p) syms' path options ud xs' + in case cmd of + "define" -> skipn (insertST def syms) True Keep xs + "undef" -> skipn (deleteST sym syms) True Keep xs + "ifndef" -> skipn syms False (keepIf (not (definedST sym syms))) xs + "ifdef" -> skipn syms False (keepIf (definedST sym syms)) xs + "if" -> skipn syms False + (keepIf (gatherDefined p syms (unwords line))) xs + "else" -> skipn syms False (Drop 1 False) xs + "elif" -> skipn syms False (Drop 1 True) xs + "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 + else skipn syms False Keep xs + "error" -> error (l++"\nin "++show p) + "line" | all isDigit sym + -> (if locations options then ((p,l):) else id) $ + cpp (newpos (read sym) (un rest) p) + syms path options Keep xs + n | all isDigit n + -> (if locations options then ((p,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) + +cpp p syms path options (Drop n b) (('#':x):xs) = + let ws = words x + cmd = head ws + delse | n==1 && b = Drop 1 b + | n==1 = Keep + | otherwise = Drop n b + dend | n==1 = Keep + | otherwise = Drop (n-1) b + delif s | n==1 && not b && gatherDefined p syms s + = Keep + | 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' + in + if cmd == "ifndef" || + cmd == "if" || + cmd == "ifdef" then skipn (Drop (n+1) b) xs + else if cmd == "elif" then skipn (delif (unwords (tail ws))) xs + else if cmd == "else" then skipn delse xs + else if cmd == "endif" then skipn dend xs + else skipn (Drop n b) xs + -- define, undef, include, error, warning, pragma, line + +cpp p syms path options Keep (x:xs) = + let p' = newline p in seq p' $ + (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 + + +---- +gatherDefined :: Posn -> SymTab HashDefine -> String -> Bool +gatherDefined p st inp = + case papply (parseBoolExp st) inp of + [] -> error ("Cannot parse #if directive in file "++show p) + [(b,_)] -> b + _ -> error ("Ambiguous parse for #if directive in file "++show p) + +parseBoolExp :: SymTab HashDefine -> Parser Bool +parseBoolExp st = + do a <- parseExp1 st + skip (string "||") + b <- first (skip (parseBoolExp st)) + return (a || b) + +++ + parseExp1 st + +parseExp1 :: SymTab HashDefine -> Parser Bool +parseExp1 st = + do a <- parseExp0 st + skip (string "&&") + b <- first (skip (parseExp1 st)) + return (a && b) + +++ + parseExp0 st + +parseExp0 :: SymTab HashDefine -> Parser Bool +parseExp0 st = + do skip (string "defined") + sym <- parens parseSym + return (definedST sym st) + +++ + do parens (parseBoolExp st) + +++ + do skip (char '!') + a <- parseExp0 st + return (not a) + +++ + do sym1 <- parseSymOrCall st + op <- parseOp st + sym2 <- parseSymOrCall st + return (op (safeRead sym1) (safeRead sym2)) + +++ + do sym <- parseSymOrCall st + case safeRead sym of + 0 -> return False + _ -> return True + where + safeRead s = + case s of + '0':'x':s' -> number readHex s' + '0':'o':s' -> number readOct s' + _ -> number readDec s + number rd s = + case rd s of + [] -> 0 :: Integer + ((n,_):_) -> n :: Integer + +parseOp :: SymTab HashDefine -> Parser (Integer -> Integer -> Bool) +parseOp _ = + do skip (string ">=") + return (>=) + +++ + do skip (char '>') + return (>) + +++ + do skip (string "<=") + return (<=) + +++ + do skip (char '<') + return (<) + +++ + do skip (string "==") + return (==) + +++ + do skip (string "!=") + return (/=) + +parseSymOrCall :: SymTab HashDefine -> Parser String +parseSymOrCall st = + do sym <- skip parseSym + args <- parens (parseSymOrCall st `sepby` skip (char ',')) + return (convert sym args) + +++ + do sym <- skip parseSym + return (convert sym []) + where + convert sym args = + case lookupST sym st of + Nothing -> sym + Just (a@SymbolReplacement{}) -> recursivelyExpand st (replacement a) + Just (a@MacroExpansion{}) -> expandMacro a args False + +recursivelyExpand :: SymTab HashDefine -> String -> String +recursivelyExpand st inp = + case papply (parseSymOrCall st) inp of + [(b,_)] -> b + _ -> inp + +parseSym :: Parser String +parseSym = many1 (alphanum+++char '\''+++char '`') + +parens p = bracket (skip (char '(')) (skip p) (skip (char ')')) + +-- | Determine filename in \#include +file :: SymTab HashDefine -> String -> String +file st name = + case name of + ('"':ns) -> init ns + ('<':ns) -> init ns + _ -> let ex = recursivelyExpand st name in + if ex == name then name else file st ex+ diff --git a/docs/cpphs/Language/Preprocessor/Cpphs/HashDefine.html b/docs/cpphs/Language/Preprocessor/Cpphs/HashDefine.html --- a/docs/cpphs/Language/Preprocessor/Cpphs/HashDefine.html +++ b/docs/cpphs/Language/Preprocessor/Cpphs/HashDefine.html @@ -1,108 +1,111 @@ ------------------------------------------------------------------------------ --- | --- Module : HashDefine --- Copyright : 2004 Malcolm Wallace --- Licence : LGPL --- --- Maintainer : Malcolm Wallace <Malcolm.Wallace@cs.york.ac.uk> --- Stability : experimental --- Portability : All --- --- What structures are declared in a \#define. ------------------------------------------------------------------------------ - -module Language.Preprocessor.Cpphs.HashDefine - ( HashDefine(..) - , ArgOrText(..) - , expandMacro - , parseHashDefine - ) where - -import Char (isSpace) -import List (intersperse) - -data HashDefine - = LineDrop - { name :: String } - | Pragma - { name :: String } - | SymbolReplacement - { name :: String - , replacement :: String - , linebreaks :: Int - } - | MacroExpansion - { name :: String - , arguments :: [String] - , expansion :: [(ArgOrText,String)] - , linebreaks :: Int - } - deriving (Eq,Show) - --- | 'smart' constructor to avoid warnings from ghc (undefined fields) -symbolReplacement :: HashDefine -symbolReplacement = - SymbolReplacement - { name=undefined, replacement=undefined, linebreaks=undefined } - --- | 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). -data ArgOrText = Arg | Text | Str deriving (Eq,Show) - --- | Expand an instance of a macro. --- Precondition: got a match on the macro name. -expandMacro :: HashDefine -> [String] -> Bool -> String -expandMacro macro parameters layout = - let env = zip (arguments macro) parameters - replace (Arg,s) = maybe (error "formal param") id (lookup s env) - replace (Str,s) = maybe (error "formal param") str (lookup s env) - replace (Text,s) = if layout then s else filter (/='\n') s - str s = '"':s++"\"" - in - concatMap replace (expansion macro) - --- | Parse a \#define, or \#undef, ignoring other \# directives -parseHashDefine :: Bool -> [String] -> Maybe HashDefine -parseHashDefine ansi def = (command . skip) def - where - skip xss@(x:xs) | all isSpace x = skip xs - | otherwise = xss - skip [] = [] - command ("line":xs) = Just (LineDrop ("#line"++concat xs)) - command ("pragma":xs) = Just (Pragma ("#pragma"++concat xs)) - command ("define":xs) = Just (((define . skip) xs) { linebreaks=count def }) - command ("undef":xs) = Just (((undef . skip) xs) { linebreaks=count def }) - command _ = Nothing - undef (sym:_) = symbolReplacement { name=sym, replacement=sym } - define (sym:xs) = case {-skip-} xs of - ("(":ys) -> (macroHead sym [] . skip) ys - ys -> symbolReplacement - { name=sym - , replacement = concatMap snd - (classifyRhs [] (chop (skip ys))) } - macroHead sym args (",":xs) = (macroHead sym args . skip) xs - macroHead sym args (")":xs) = MacroExpansion - { name =sym , arguments = reverse args - , expansion = classifyRhs args (skip xs) - , linebreaks = undefined } - macroHead sym args (var:xs) = (macroHead sym (var:args) . skip) xs - macroHead sym args [] = error ("incomplete macro definition:\n" - ++" #define "++sym++"(" - ++concat (intersperse "," args)) - classifyRhs args ("#":x:xs) - | ansi && - x `elem` args = (Str,x): classifyRhs args xs - classifyRhs args ("##":xs) - | ansi = classifyRhs args xs - classifyRhs args (s:"##":s':xs) - | ansi && all isSpace s && all isSpace s' - = classifyRhs args xs - classifyRhs args (word:xs) - | word `elem` args = (Arg,word): classifyRhs args xs - | otherwise = (Text,word): classifyRhs args xs - classifyRhs _ [] = [] - count = length . filter (=='\n') . concat - chop = reverse . dropWhile (all isSpace) . reverse - + + +----------------------------------------------------------------------------- +-- | +-- Module : HashDefine +-- Copyright : 2004 Malcolm Wallace +-- Licence : LGPL +-- +-- Maintainer : Malcolm Wallace <Malcolm.Wallace@cs.york.ac.uk> +-- Stability : experimental +-- Portability : All +-- +-- What structures are declared in a \#define. +----------------------------------------------------------------------------- + +module Language.Preprocessor.Cpphs.HashDefine + ( HashDefine(..) + , ArgOrText(..) + , expandMacro + , parseHashDefine + ) where + +import Char (isSpace) +import List (intersperse) + +data HashDefine + = LineDrop + { name :: String } + | Pragma + { name :: String } + | SymbolReplacement + { name :: String + , replacement :: String + , linebreaks :: Int + } + | MacroExpansion + { name :: String + , arguments :: [String] + , expansion :: [(ArgOrText,String)] + , linebreaks :: Int + } + deriving (Eq,Show) + +-- | 'smart' constructor to avoid warnings from ghc (undefined fields) +symbolReplacement :: HashDefine +symbolReplacement = + SymbolReplacement + { name=undefined, replacement=undefined, linebreaks=undefined } + +-- | 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). +data ArgOrText = Arg | Text | Str deriving (Eq,Show) + +-- | Expand an instance of a macro. +-- Precondition: got a match on the macro name. +expandMacro :: HashDefine -> [String] -> Bool -> String +expandMacro macro parameters layout = + let env = zip (arguments macro) parameters + replace (Arg,s) = maybe (error "formal param") id (lookup s env) + replace (Str,s) = maybe (error "formal param") str (lookup s env) + replace (Text,s) = if layout then s else filter (/='\n') s + str s = '"':s++"\"" + in + concatMap replace (expansion macro) + +-- | Parse a \#define, or \#undef, ignoring other \# directives +parseHashDefine :: Bool -> [String] -> Maybe HashDefine +parseHashDefine ansi def = (command . skip) def + where + skip xss@(x:xs) | all isSpace x = skip xs + | otherwise = xss + skip [] = [] + command ("line":xs) = Just (LineDrop ("#line"++concat xs)) + command ("pragma":xs) = Just (Pragma ("#pragma"++concat xs)) + command ("define":xs) = Just (((define . skip) xs) { linebreaks=count def }) + command ("undef":xs) = Just (((undef . skip) xs) { linebreaks=count def }) + command _ = Nothing + undef (sym:_) = symbolReplacement { name=sym, replacement=sym } + define (sym:xs) = case {-skip-} xs of + ("(":ys) -> (macroHead sym [] . skip) ys + ys -> symbolReplacement + { name=sym + , replacement = concatMap snd + (classifyRhs [] (chop (skip ys))) } + macroHead sym args (",":xs) = (macroHead sym args . skip) xs + macroHead sym args (")":xs) = MacroExpansion + { name =sym , arguments = reverse args + , expansion = classifyRhs args (skip xs) + , linebreaks = undefined } + macroHead sym args (var:xs) = (macroHead sym (var:args) . skip) xs + macroHead sym args [] = error ("incomplete macro definition:\n" + ++" #define "++sym++"(" + ++concat (intersperse "," args)) + classifyRhs args ("#":x:xs) + | ansi && + x `elem` args = (Str,x): classifyRhs args xs + classifyRhs args ("##":xs) + | ansi = classifyRhs args xs + classifyRhs args (s:"##":s':xs) + | ansi && all isSpace s && all isSpace s' + = classifyRhs args xs + classifyRhs args (word:xs) + | word `elem` args = (Arg,word): classifyRhs args xs + | otherwise = (Text,word): classifyRhs args xs + classifyRhs _ [] = [] + count = length . filter (=='\n') . concat + chop = reverse . dropWhile (all isSpace) . reverse ++ diff --git a/docs/cpphs/Language/Preprocessor/Cpphs/MacroPass.html b/docs/cpphs/Language/Preprocessor/Cpphs/MacroPass.html --- a/docs/cpphs/Language/Preprocessor/Cpphs/MacroPass.html +++ b/docs/cpphs/Language/Preprocessor/Cpphs/MacroPass.html @@ -1,129 +1,133 @@ ------------------------------------------------------------------------------ --- | --- 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 - 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 False lang - [(p,expandMacro hd args' layout)] - ++ ws') - + + +----------------------------------------------------------------------------- +-- | +-- 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 (stripEol options) (stripC89 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 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 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 + 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') ++ diff --git a/docs/cpphs/Language/Preprocessor/Cpphs/Options.html b/docs/cpphs/Language/Preprocessor/Cpphs/Options.html --- a/docs/cpphs/Language/Preprocessor/Cpphs/Options.html +++ b/docs/cpphs/Language/Preprocessor/Cpphs/Options.html @@ -1,135 +1,150 @@ ------------------------------------------------------------------------------ --- | --- Module : Options --- Copyright : 2006 Malcolm Wallace --- Licence : LGPL --- --- Maintainer : Malcolm Wallace <Malcolm.Wallace@cs.york.ac.uk> --- Stability : experimental --- Portability : All --- --- This module deals with Cpphs options and parsing them ------------------------------------------------------------------------------ - -module Language.Preprocessor.Cpphs.Options - ( CpphsOptions(..) - , BoolOptions(..) - , parseOptions - , defaultCpphsOptions - , defaultBoolOptions - ) where - -import Maybe - --- | Cpphs options structure. -data CpphsOptions = CpphsOptions - { infiles :: [FilePath] - , outfiles :: [FilePath] - , defines :: [(String,String)] - , includes :: [String] - , boolopts :: BoolOptions - } - --- | Default options. -defaultCpphsOptions :: CpphsOptions -defaultCpphsOptions = CpphsOptions { infiles = [], outfiles = [] - , defines = [], includes = [] - , boolopts = defaultBoolOptions } - --- | Options representable as Booleans. -data BoolOptions = BoolOptions - { macros :: Bool -- ^ Leave \#define and \#undef in output of ifdef? - , locations :: Bool -- ^ Place \#line droppings in output? - , pragma :: Bool -- ^ Keep \#pragma in final output? - , strip :: Bool -- ^ Remove C comments everywhere? - , lang :: Bool -- ^ Lex input as Haskell code? - , ansi :: Bool -- ^ Permit stringise # and catenate ## operators? - , layout :: Bool -- ^ Retain newlines in macro expansions? - , literate :: Bool -- ^ Remove literate markup? - , warnings :: Bool -- ^ Issue warnings? - } - --- | Default settings of boolean options. -defaultBoolOptions :: BoolOptions -defaultBoolOptions = BoolOptions { macros = True, locations = True - , pragma = False, strip = False - , lang = True, ansi = False - , layout = False, literate = False - , warnings = True } - --- | Raw command-line options. This is an internal intermediate data --- structure, used during option parsing only. -data RawOption - = NoMacro - | NoLine - | Pragma - | Text - | Strip - | Ansi - | Layout - | Unlit - | SuppressWarnings - | Macro (String,String) - | Path String - deriving (Eq, Show) - -flags :: [(String, RawOption)] -flags = [ ("--nomacro", NoMacro) - , ("--noline", NoLine) - , ("--pragma", Pragma) - , ("--text", Text) - , ("--strip", Strip) - , ("--hashes", Ansi) - , ("--layout", Layout) - , ("--unlit", Unlit) - , ("--nowarn", SuppressWarnings) - ] - --- | Parse a single raw command-line option. Parse failure is indicated by --- result Nothing. -rawOption :: String -> Maybe RawOption -rawOption x | isJust a = a - where a = lookup x flags -rawOption ('-':'D':xs) = Just $ Macro (s, if null d then "1" else tail d) - where (s,d) = break (=='=') xs -rawOption ('-':'I':xs) = Just $ Path $ trailing "/\\" xs -rawOption _ = Nothing - -trailing :: (Eq a) => [a] -> [a] -> [a] -trailing xs = reverse . dropWhile (`elem`xs) . reverse - --- | Convert a list of RawOption to a BoolOptions structure. -boolOpts :: [RawOption] -> BoolOptions -boolOpts opts = - BoolOptions - { macros = not (NoMacro `elem` opts) - , locations = not (NoLine `elem` opts) - , pragma = Pragma `elem` opts - , strip = Strip `elem` opts - , lang = not (Text `elem` opts) - , ansi = Ansi `elem` opts - , layout = Layout `elem` opts - , literate = Unlit `elem` opts - , warnings = not (SuppressWarnings `elem` opts) - } - --- | Parse all command-line options. -parseOptions :: [String] -> Either String CpphsOptions -parseOptions xs = f ([], [], []) xs - where - f (opts, ins, outs) (('-':'O':x):xs) = f (opts, ins, x:outs) xs - f (opts, ins, outs) (x@('-':_):xs) = case rawOption x of - Nothing -> Left x - Just a -> f (a:opts, ins, outs) xs - f (opts, ins, outs) (x:xs) = f (opts, normalise x:ins, outs) xs - f (opts, ins, outs) [] = - Right CpphsOptions { infiles = reverse ins - , outfiles = reverse outs - , defines = [ x | Macro x <- reverse opts ] - , includes = [ x | Path x <- reverse opts ] - , boolopts = boolOpts opts - } - normalise ('/':'/':filepath) = normalise ('/':filepath) - normalise (x:filepath) = x:normalise filepath - normalise [] = [] + + +----------------------------------------------------------------------------- +-- | +-- Module : Options +-- Copyright : 2006 Malcolm Wallace +-- Licence : LGPL +-- +-- Maintainer : Malcolm Wallace <Malcolm.Wallace@cs.york.ac.uk> +-- Stability : experimental +-- Portability : All +-- +-- This module deals with Cpphs options and parsing them +----------------------------------------------------------------------------- + +module Language.Preprocessor.Cpphs.Options + ( CpphsOptions(..) + , BoolOptions(..) + , parseOptions + , defaultCpphsOptions + , defaultBoolOptions + ) where + +import Maybe +import List (isPrefixOf) + +-- | Cpphs options structure. +data CpphsOptions = CpphsOptions + { infiles :: [FilePath] + , outfiles :: [FilePath] + , defines :: [(String,String)] + , includes :: [String] + , preInclude:: [FilePath] -- ^ Files to #include before anything else + , boolopts :: BoolOptions + } + +-- | Default options. +defaultCpphsOptions :: CpphsOptions +defaultCpphsOptions = CpphsOptions { infiles = [], outfiles = [] + , defines = [], includes = [] + , preInclude = [] + , boolopts = defaultBoolOptions } + +-- | Options representable as Booleans. +data BoolOptions = BoolOptions + { macros :: Bool -- ^ Leave \#define and \#undef in output of ifdef? + , locations :: Bool -- ^ Place #line droppings in output? + , pragma :: Bool -- ^ Keep #pragma in final output? + , stripEol :: Bool -- ^ Remove C eol (\/\/) comments everywhere? + , stripC89 :: Bool -- ^ Remove C inline (\/**\/) comments everywhere? + , lang :: Bool -- ^ Lex input as Haskell code? + , ansi :: Bool -- ^ Permit stringise \# and catenate \#\# operators? + , layout :: Bool -- ^ Retain newlines in macro expansions? + , literate :: Bool -- ^ Remove literate markup? + , warnings :: Bool -- ^ Issue warnings? + } + +-- | Default settings of boolean options. +defaultBoolOptions :: BoolOptions +defaultBoolOptions = BoolOptions { macros = True, locations = True + , pragma = False + , stripEol = False, stripC89 = False + , lang = True, ansi = False + , layout = False, literate = False + , warnings = True } + +-- | Raw command-line options. This is an internal intermediate data +-- structure, used during option parsing only. +data RawOption + = NoMacro + | NoLine + | Pragma + | Text + | Strip + | StripEol + | Ansi + | Layout + | Unlit + | SuppressWarnings + | Macro (String,String) + | Path String + | PreInclude FilePath + deriving (Eq, Show) + +flags :: [(String, RawOption)] +flags = [ ("--nomacro", NoMacro) + , ("--noline", NoLine) + , ("--pragma", Pragma) + , ("--text", Text) + , ("--strip", Strip) + , ("--strip-eol", StripEol) + , ("--hashes", Ansi) + , ("--layout", Layout) + , ("--unlit", Unlit) + , ("--nowarn", SuppressWarnings) + ] + +-- | Parse a single raw command-line option. Parse failure is indicated by +-- result Nothing. +rawOption :: String -> Maybe RawOption +rawOption x | isJust a = a + where a = lookup x flags +rawOption ('-':'D':xs) = Just $ Macro (s, if null d then "1" else tail d) + where (s,d) = break (=='=') xs +rawOption ('-':'I':xs) = Just $ Path $ trailing "/\\" xs +rawOption xs | "--include="`isPrefixOf`xs + = Just $ PreInclude (drop 10 xs) +rawOption _ = Nothing + +trailing :: (Eq a) => [a] -> [a] -> [a] +trailing xs = reverse . dropWhile (`elem`xs) . reverse + +-- | Convert a list of RawOption to a BoolOptions structure. +boolOpts :: [RawOption] -> BoolOptions +boolOpts opts = + BoolOptions + { macros = not (NoMacro `elem` opts) + , locations = not (NoLine `elem` opts) + , pragma = Pragma `elem` opts + , stripEol = StripEol`elem` opts + , stripC89 = StripEol`elem` opts || Strip `elem` opts + , lang = not (Text `elem` opts) + , ansi = Ansi `elem` opts + , layout = Layout `elem` opts + , literate = Unlit `elem` opts + , warnings = not (SuppressWarnings `elem` opts) + } + +-- | Parse all command-line options. +parseOptions :: [String] -> Either String CpphsOptions +parseOptions xs = f ([], [], []) xs + where + f (opts, ins, outs) (('-':'O':x):xs) = f (opts, ins, x:outs) xs + f (opts, ins, outs) (x@('-':_):xs) = case rawOption x of + Nothing -> Left x + Just a -> f (a:opts, ins, outs) xs + f (opts, ins, outs) (x:xs) = f (opts, normalise x:ins, outs) xs + f (opts, ins, outs) [] = + Right CpphsOptions { infiles = reverse ins + , outfiles = reverse outs + , defines = [ x | Macro x <- reverse opts ] + , includes = [ x | Path x <- reverse opts ] + , preInclude=[ x | PreInclude x <- reverse opts ] + , boolopts = boolOpts opts + } + normalise ('/':'/':filepath) = normalise ('/':filepath) + normalise (x:filepath) = x:normalise filepath + normalise [] = []+ diff --git a/docs/cpphs/Language/Preprocessor/Cpphs/Position.html b/docs/cpphs/Language/Preprocessor/Cpphs/Position.html --- a/docs/cpphs/Language/Preprocessor/Cpphs/Position.html +++ b/docs/cpphs/Language/Preprocessor/Cpphs/Position.html @@ -1,81 +1,84 @@ ------------------------------------------------------------------------------ --- | --- 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 - + + +----------------------------------------------------------------------------- +-- | +-- 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 ++ diff --git a/docs/cpphs/Language/Preprocessor/Cpphs/ReadFirst.html b/docs/cpphs/Language/Preprocessor/Cpphs/ReadFirst.html --- a/docs/cpphs/Language/Preprocessor/Cpphs/ReadFirst.html +++ b/docs/cpphs/Language/Preprocessor/Cpphs/ReadFirst.html @@ -1,54 +1,57 @@ ------------------------------------------------------------------------------ --- | --- Module : ReadFirst --- Copyright : 2004 Malcolm Wallace --- Licence : LGPL --- --- Maintainer : Malcolm Wallace <Malcolm.Wallace@cs.york.ac.uk> --- Stability : experimental --- Portability : All --- --- Read the first file that matches in a list of search paths. ------------------------------------------------------------------------------ - -module Language.Preprocessor.Cpphs.ReadFirst - ( readFirst - ) where - -import IO (hPutStrLn, stderr) -import Directory (doesFileExist) -import List (intersperse) -import Monad (when) -import Language.Preprocessor.Cpphs.Position (Posn,directory) - --- | 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.) -readFirst :: String -- ^ filename - -> Posn -- ^ inclusion point - -> [String] -- ^ search path - -> Bool -- ^ report warnings? - -> IO ( FilePath - , String - ) -- ^ discovered filepath, and file contents - -readFirst name demand path warn = - try (cons dd (".":path)) - where - dd = directory demand - cons x xs = if null x then xs else x:xs - try [] = do - when warn $ - hPutStrLn stderr ("Warning: Can't find file \""++name - ++"\" in directories\n\t" - ++concat (intersperse "\n\t" (cons dd (".":path))) - ++"\n Asked for by: "++show demand) - return ("missing file: "++name,"") - try (p:ps) = do - let file = p++'/':name - ok <- doesFileExist file - if not ok then try ps - else do content <- readFile file - return (file,content) + + +----------------------------------------------------------------------------- +-- | +-- Module : ReadFirst +-- Copyright : 2004 Malcolm Wallace +-- Licence : LGPL +-- +-- Maintainer : Malcolm Wallace <Malcolm.Wallace@cs.york.ac.uk> +-- Stability : experimental +-- Portability : All +-- +-- Read the first file that matches in a list of search paths. +----------------------------------------------------------------------------- + +module Language.Preprocessor.Cpphs.ReadFirst + ( readFirst + ) where + +import IO (hPutStrLn, stderr) +import Directory (doesFileExist) +import List (intersperse) +import Monad (when) +import Language.Preprocessor.Cpphs.Position (Posn,directory) + +-- | 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.) +readFirst :: String -- ^ filename + -> Posn -- ^ inclusion point + -> [String] -- ^ search path + -> Bool -- ^ report warnings? + -> IO ( FilePath + , String + ) -- ^ discovered filepath, and file contents + +readFirst name demand path warn = + try (cons dd (".":path)) + where + dd = directory demand + cons x xs = if null x then xs else x:xs + try [] = do + when warn $ + hPutStrLn stderr ("Warning: Can't find file \""++name + ++"\" in directories\n\t" + ++concat (intersperse "\n\t" (cons dd (".":path))) + ++"\n Asked for by: "++show demand) + return ("missing file: "++name,"") + try (p:ps) = do + let file = p++'/':name + ok <- doesFileExist file + if not ok then try ps + else do content <- readFile file + return (file,content)+ diff --git a/docs/cpphs/Language/Preprocessor/Cpphs/RunCpphs.html b/docs/cpphs/Language/Preprocessor/Cpphs/RunCpphs.html --- a/docs/cpphs/Language/Preprocessor/Cpphs/RunCpphs.html +++ b/docs/cpphs/Language/Preprocessor/Cpphs/RunCpphs.html @@ -1,26 +1,32 @@ -{- --- 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 + + +{- +-- 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 + preInc = concatMap (\f->"#include \""++f++"\"\n") (preInclude options) +-- ++ "#line 1\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 + pass3 = if literate bools then Unlit.unlit filename else id + + in pass3 result+ diff --git a/docs/cpphs/Language/Preprocessor/Cpphs/SymTab.html b/docs/cpphs/Language/Preprocessor/Cpphs/SymTab.html --- a/docs/cpphs/Language/Preprocessor/Cpphs/SymTab.html +++ b/docs/cpphs/Language/Preprocessor/Cpphs/SymTab.html @@ -1,87 +1,90 @@ ------------------------------------------------------------------------------ --- | --- 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) - in if 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 : 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) + in if 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 + +----+ diff --git a/docs/cpphs/Language/Preprocessor/Cpphs/Tokenise.html b/docs/cpphs/Language/Preprocessor/Cpphs/Tokenise.html --- a/docs/cpphs/Language/Preprocessor/Cpphs/Tokenise.html +++ b/docs/cpphs/Language/Preprocessor/Cpphs/Tokenise.html @@ -1,257 +1,275 @@ ------------------------------------------------------------------------------ --- | --- 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 - + + +----------------------------------------------------------------------------- +-- | +-- 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 | CLineComment + +-- | 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 -> Bool -> [(Posn,String)] -> [WordStyle] +tokenise _ _ _ _ [] = [] +tokenise stripEol stripComments 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) + | stripComments = emit acc $ + haskell CComment " " p ls xs + haskell Any acc p ls ('/':'/':xs) + | stripEol = emit acc $ + haskell CLineComment " " 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 CLineComment acc p ls xs@('\n':_)= emit acc $ haskell Any [] p ls xs + haskell CLineComment acc p ls (_:xs) = haskell CLineComment (' ':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) + | stripComments = emit acc $ + plaintext CComment " " p ls xs + plaintext Any acc p ls ('/':'/':xs) + | stripEol = emit acc $ + plaintext CLineComment " " 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 CLineComment acc p ls xs@('\n':_) + = emit acc $ plaintext Any [] p ls xs + plaintext CLineComment acc p ls (_:xs)= plaintext CLineComment (' ':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 ++ diff --git a/docs/cpphs/Language/Preprocessor/Unlit.html b/docs/cpphs/Language/Preprocessor/Unlit.html --- a/docs/cpphs/Language/Preprocessor/Unlit.html +++ b/docs/cpphs/Language/Preprocessor/Unlit.html @@ -1,71 +1,74 @@ --- | 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:)) - + + +-- | 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:rest) | all isDigit line + -> Include (read line) (unwords rest) + _ -> 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:)) ++ diff --git a/docs/cpphs/Text/ParserCombinators/HuttonMeijer.html b/docs/cpphs/Text/ParserCombinators/HuttonMeijer.html --- a/docs/cpphs/Text/ParserCombinators/HuttonMeijer.html +++ b/docs/cpphs/Text/ParserCombinators/HuttonMeijer.html @@ -1,219 +1,222 @@ ------------------------------------------------------------------------------ --- | --- 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}) - ------------------------------------------------------------------------------- + + +----------------------------------------------------------------------------- +-- | +-- 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}) + +------------------------------------------------------------------------------+ diff --git a/docs/cpphs/cpphs.html b/docs/cpphs/cpphs.html --- a/docs/cpphs/cpphs.html +++ b/docs/cpphs/cpphs.html @@ -1,109 +1,113 @@ -{- --- 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 - in do 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 /= "-"] - - + + +{- +-- 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.6" + +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] [--strip-eol] [--hashes] [--layout] [--unlit]\n" + ++"\t\t[ --cpp std-cpp-options ] [--include=filename]") + 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 + in do 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 language spec + f e ("-include":x:xs) = ("--include="++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" | traditional e && strip e] ++ + ["--strip-eol" | not (traditional e) && strip e] ++ + [infile e] ++ + ["-O" ++ outfile e | outfile e /= "-"] + ++ diff --git a/docs/cpphs/doc-index-P.html b/docs/cpphs/doc-index-P.html --- a/docs/cpphs/doc-index-P.html +++ b/docs/cpphs/doc-index-P.html @@ -221,6 +221,16 @@ >Language.Preprocessor.Cpphs.MacroPass
Usage: cpphs [ filename | -Dsym | -Dsym=val | -Ipath ]+ [-Ofile]
- [--nomacro] [--noline] [--nowarn] [--pragma] [--strip]
+ [--nomacro] [--noline] [--nowarn] [--pragma]
+ [--strip] [--strip-eol]
[--text] [--hashes] [--layout] [--unlit]
[ --cpp compatopts ]
cpphs --version
@@ -124,6 +125,13 @@
carry over into the next.) If no filename is given, cpphs reads from
standard input.
+ Note: if you wish to use cpphs as a replacement for gcc's
+cpp in conjunction with the ghc compiler then the extra options you need
+to give to ghc are these:
+
+ -cpp -pgmPcpphs -optP--cpp
+
+
Options:
| --pragma | retain #pragma in the output (normally removed) |
| --strip | -convert C-style comments to whitespace, even outside - cpp directives | convert traditional C-style comments (not eol //) to whitespace, + even outside cpp directives | +
| --strip-eol | +convert modern C-style comments (including /**/ and //) to whitespace, + even outside cpp directives |
| --hashes | recognise the ANSI # stringise operator, and ## for token catenation, within macros |