module Language.Preprocessor.Cpphs.MacroPass
( macroPass
, preDefine
, defineMacro
, macroPassReturningSymTab
) where
import Language.Preprocessor.Cpphs.HashDefine (HashDefine(..), expandMacro
, simplifyHashDefines)
import Language.Preprocessor.Cpphs.Tokenise (tokenise, WordStyle(..)
, parseMacroCall)
import Language.Preprocessor.Cpphs.SymTab (SymTab, lookupST, insertST
, emptyST, flattenST)
import Language.Preprocessor.Cpphs.Position (Posn, newfile, filename, lineno)
import Language.Preprocessor.Cpphs.Options (BoolOptions(..))
import System.IO.Unsafe (unsafeInterleaveIO)
import Control.Monad ((=<<))
import System.Time (getClockTime, toCalendarTime, formatCalendarTime)
import System.Locale (defaultTimeLocale)
noPos :: Posn
noPos = newfile "preDefined"
macroPass :: [(String,String)]
-> BoolOptions
-> [(Posn,String)]
-> IO String
macroPass syms options =
fmap (safetail
. concat
. onlyRights)
. macroProcess (pragma options) (layout options) (lang options)
(preDefine options syms)
. tokenise (stripEol options) (stripC89 options)
(ansi options) (lang options)
. ((noPos,""):)
where
safetail [] = []
safetail (_:xs) = xs
onlyRights :: [Either a b] -> [b]
onlyRights = concatMap (\x->case x of Right t-> [t]; Left _-> [];)
macroPassReturningSymTab
:: [(String,String)]
-> BoolOptions
-> [(Posn,String)]
-> IO (String,[(String,String)])
macroPassReturningSymTab syms options =
fmap (mapFst (safetail
. concat)
. walk)
. macroProcess (pragma options) (layout options) (lang options)
(preDefine options syms)
. tokenise (stripEol options) (stripC89 options)
(ansi options) (lang options)
. ((noPos,""):)
where
safetail [] = []
safetail (_:xs) = xs
walk (Right x: rest) = let (xs, foo) = walk rest
in (x:xs, foo)
walk (Left x: []) = ( [] , simplifyHashDefines (flattenST x) )
walk (Left x: rest) = walk rest
mapFst f (a,b) = (f a, b)
preDefine :: BoolOptions -> [(String,String)] -> SymTab HashDefine
preDefine options defines =
foldr (insertST . defineMacro options . (\ (s,d)-> s++" "++d))
emptyST defines
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)
macroProcess :: Bool -> Bool -> Bool -> SymTab HashDefine -> [WordStyle]
-> IO [Either (SymTab HashDefine) String]
macroProcess _ _ _ st [] = return [Left st]
macroProcess p y l st (Other x: ws) = emit x $ macroProcess p y l st ws
macroProcess p y l st (Cmd Nothing: ws) = emit "\n" $ macroProcess p y l st ws
macroProcess p y l st (Cmd (Just (LineDrop x)): ws)
= emit "\n" $
emit x $ macroProcess p y l st ws
macroProcess pragma y l st (Cmd (Just (Pragma x)): ws)
| pragma = emit "\n" $ emit x $ macroProcess pragma y l st ws
| otherwise = emit "\n" $ macroProcess pragma y l st ws
macroProcess p layout lang st (Cmd (Just hd): ws) =
let n = 1 + linebreaks hd
newST = insertST (name hd, hd) st
in
emit (replicate n '\n') $
emitSymTab newST $
macroProcess p layout lang newST ws
macroProcess pr layout lang st (Ident p x: ws) =
case x of
"__FILE__" -> emit (show (filename p))$ macroProcess pr layout lang st ws
"__LINE__" -> emit (show (lineno p)) $ macroProcess pr layout lang st ws
"__DATE__" -> do w <- return .
formatCalendarTime defaultTimeLocale "\"%d %b %Y\""
=<< toCalendarTime =<< getClockTime
emit w $ macroProcess pr layout lang st ws
"__TIME__" -> do w <- return .
formatCalendarTime defaultTimeLocale "\"%H:%M:%S\""
=<< toCalendarTime =<< getClockTime
emit w $ macroProcess pr layout lang st ws
_ ->
case lookupST x st of
Nothing -> emit x $ macroProcess pr layout lang st ws
Just hd ->
case hd of
AntiDefined {name=n} -> emit n $
macroProcess pr layout lang st ws
SymbolReplacement {replacement=r} ->
let r' = if layout then r else filter (/='\n') r in
macroProcess pr layout lang st
(tokenise True True False lang [(p,r')]
++ ws)
MacroExpansion {} ->
case parseMacroCall p ws of
Nothing -> emit x $
macroProcess pr layout lang st ws
Just (args,ws') ->
if length args /= length (arguments hd) then
emit x $ macroProcess pr layout lang st ws
else do args' <- mapM (fmap (concat.onlyRights)
. macroProcess pr layout
lang st)
args
macroProcess pr layout lang st
(tokenise True True False lang
[(p,expandMacro hd args' layout)]
++ ws')
emit :: a -> IO [Either b a] -> IO [Either b a]
emit x io = do xs <- unsafeInterleaveIO io
return (Right x:xs)
emitSymTab :: b -> IO [Either b a] -> IO [Either b a]
emitSymTab x io = do xs <- unsafeInterleaveIO io
return (Left x:xs)