1-----------------------------------------------------------------------------
2-- |
3-- Module      :  MacroPass
4-- Copyright   :  2004 Malcolm Wallace
5-- Licence     :  LGPL
6--
7-- Maintainer  :  Malcolm Wallace <Malcolm.Wallace@cs.york.ac.uk>
8-- Stability   :  experimental
9-- Portability :  All
10--
11-- Perform a cpp.second-pass, accumulating \#define's and \#undef's,
12-- whilst doing symbol replacement and macro expansion.
13-----------------------------------------------------------------------------
14
15module Language.Preprocessor.Cpphs.MacroPass
16  ( macroPass
17  , preDefine
18  , defineMacro
19  , macroPassReturningSymTab
20  ) where
21
22import Language.Preprocessor.Cpphs.HashDefine (HashDefine(..), expandMacro
23                                              , simplifyHashDefines)
24import Language.Preprocessor.Cpphs.Tokenise   (tokenise, WordStyle(..)
25                                              , parseMacroCall)
26import Language.Preprocessor.Cpphs.SymTab     (SymTab, lookupST, insertST
27                                              , emptyST, flattenST)
28import Language.Preprocessor.Cpphs.Position   (Posn, newfile, filename, lineno)
29import Language.Preprocessor.Cpphs.Options    (BoolOptions(..))
30import System.IO.Unsafe (unsafeInterleaveIO)
31import Control.Monad    ((=<<))
32--import System.Time       (getClockTime, toCalendarTime, formatCalendarTime)
33import Data.Time.Clock  (getCurrentTime)
34import Data.Time.Format (formatTime)
35import TimeCompat       (defaultTimeLocale)
36
37noPos :: Posn
38noPos = newfile "preDefined"
39
40-- | Walk through the document, replacing calls of macros with the expanded RHS.
41macroPass :: [(String,String)]  -- ^ Pre-defined symbols and their values
42          -> BoolOptions        -- ^ Options that alter processing style
43          -> [(Posn,String)]    -- ^ The input file content
44          -> IO String          -- ^ The file after processing
45macroPass syms options =
46    fmap (safetail              -- to remove extra "\n" inserted below
47         . concat
48         . onlyRights)
49    . macroProcess (pragma options) (layout options) (lang options)
50                   (preDefine options syms)
51    . tokenise (stripEol options) (stripC89 options)
52               (ansi options) (lang options)
53    . ((noPos,""):)     -- ensure recognition of "\n#" at start of file
54  where
55    safetail [] = []
56    safetail (_:xs) = xs
57
58-- | auxiliary
59onlyRights :: [Either a b] -> [b]
60onlyRights = concatMap (\x->case x of Right t-> [t]; Left _-> [];)
61
62-- | Walk through the document, replacing calls of macros with the expanded RHS.
63--   Additionally returns the active symbol table after processing.
64macroPassReturningSymTab
65          :: [(String,String)]  -- ^ Pre-defined symbols and their values
66          -> BoolOptions        -- ^ Options that alter processing style
67          -> [(Posn,String)]    -- ^ The input file content
68          -> IO (String,[(String,String)])
69                                -- ^ The file and symbol table after processing
70macroPassReturningSymTab syms options =
71    fmap (mapFst (safetail              -- to remove extra "\n" inserted below
72                 . concat)
73         . walk)
74    . macroProcess (pragma options) (layout options) (lang options)
75                   (preDefine options syms)
76    . tokenise (stripEol options) (stripC89 options)
77               (ansi options) (lang options)
78    . ((noPos,""):)     -- ensure recognition of "\n#" at start of file
79  where
80    safetail [] = []
81    safetail (_:xs) = xs
82    walk (Right x: rest) = let (xs,   foo) = walk rest
83                           in  (x:xs, foo)
84    walk (Left  x: [])   =     ( [] , simplifyHashDefines (flattenST x) )
85    walk (Left  x: rest) = walk rest
86    mapFst f (a,b) = (f a, b)
87
88
89-- | Turn command-line definitions (from @-D@) into 'HashDefine's.
90preDefine :: BoolOptions -> [(String,String)] -> SymTab HashDefine
91preDefine options defines =
92    foldr (insertST . defineMacro options . (\ (s,d)-> s++" "++d))
93          emptyST defines
94
95-- | Turn a string representing a macro definition into a 'HashDefine'.
96defineMacro :: BoolOptions -> String -> (String,HashDefine)
97defineMacro opts s =
98    let (Cmd (Just hd):_) = tokenise True True (ansi opts) (lang opts)
99                                     [(noPos,"\n#define "++s++"\n")]
100    in (name hd, hd)
101
102
103-- | Trundle through the document, one word at a time, using the WordStyle
104--   classification introduced by 'tokenise' to decide whether to expand a
105--   word or macro.  Encountering a \#define or \#undef causes that symbol to
106--   be overwritten in the symbol table.  Any other remaining cpp directives
107--   are discarded and replaced with blanks, except for \#line markers.
108--   All valid identifiers are checked for the presence of a definition
109--   of that name in the symbol table, and if so, expanded appropriately.
110--   (Bool arguments are: keep pragmas?  retain layout?  haskell language?)
111--   The result lazily intersperses output text with symbol tables.  Lines
112--   are emitted as they are encountered.  A symbol table is emitted after
113--   each change to the defined symbols, and always at the end of processing.
114macroProcess :: Bool -> Bool -> Bool -> SymTab HashDefine -> [WordStyle]
115             -> IO [Either (SymTab HashDefine) String]
116macroProcess _ _ _ st        []          = return [Left st]
117macroProcess p y l st (Other x: ws)      = emit x    $ macroProcess p y l st ws
118macroProcess p y l st (Cmd Nothing: ws)  = emit "\n" $ macroProcess p y l st ws
119macroProcess p y l st (Cmd (Just (LineDrop x)): ws)
120                                         = emit "\n" $
121                                           emit x    $ macroProcess p y l st ws
122macroProcess pragma y l st (Cmd (Just (Pragma x)): ws)
123               | pragma    = emit "\n" $ emit x $ macroProcess pragma y l st ws
124               | otherwise = emit "\n" $          macroProcess pragma y l st ws
125macroProcess p layout lang st (Cmd (Just hd): ws) =
126    let n = 1 + linebreaks hd
127        newST = insertST (name hd, hd) st
128    in
129    emit (replicate n '\n') $
130    emitSymTab newST $
131    macroProcess p layout lang newST ws
132macroProcess pr layout lang st (Ident p x: ws) =
133    case x of
134      "__FILE__" -> emit (show (filename p))$ macroProcess pr layout lang st ws
135      "__LINE__" -> emit (show (lineno p))  $ macroProcess pr layout lang st ws
136      "__DATE__" -> do w <- return .
137                         -- formatCalendarTime defaultTimeLocale "\"%d %b %Y\""
138                         -- =<< toCalendarTime =<< getClockTime
139                            formatTime defaultTimeLocale "\"%d %b %Y\""
140                            =<< getCurrentTime
141                       emit w $ macroProcess pr layout lang st ws
142      "__TIME__" -> do w <- return .
143                         -- formatCalendarTime defaultTimeLocale "\"%H:%M:%S\""
144                         -- =<< toCalendarTime =<< getClockTime
145                            formatTime defaultTimeLocale "\"%H:%M:%S\""
146                            =<< getCurrentTime
147                       emit w $ macroProcess pr layout lang st ws
148      _ ->
149        case lookupST x st of
150            Nothing -> emit x $ macroProcess pr layout lang st ws
151            Just hd ->
152                case hd of
153                    AntiDefined {name=n} -> emit n $
154                                            macroProcess pr layout lang st ws
155                    SymbolReplacement {replacement=r} ->
156                        let r' = if layout then r else filter (/='\n') r in
157                        -- one-level expansion only:
158                        -- emit r' $ macroProcess layout st ws
159                        -- multi-level expansion:
160                        macroProcess pr layout lang st
161                                     (tokenise True True False lang [(p,r')]
162                                      ++ ws)
163                    MacroExpansion {} ->
164                        case parseMacroCall p ws of
165                            Nothing -> emit x $
166                                       macroProcess pr layout lang st ws
167                            Just (args,ws') ->
168                                if length args /= length (arguments hd) then
169                                     emit x $ macroProcess pr layout lang st ws
170                                else do args' <- mapM (fmap (concat.onlyRights)
171                                                       . macroProcess pr layout
172                                                                        lang st)
173                                                      args
174                                        -- one-level expansion only:
175                                        -- emit (expandMacro hd args' layout) $
176                                        --         macroProcess layout st ws'
177                                        -- multi-level expansion:
178                                        macroProcess pr layout lang st
179                                            (tokenise True True False lang
180                                               [(p,expandMacro hd args' layout)]
181                                            ++ ws')
182
183-- | Useful helper function.
184emit :: a -> IO [Either b a] -> IO [Either b a]
185emit x io = do xs <- unsafeInterleaveIO io
186               return (Right x:xs)
187-- | Useful helper function.
188emitSymTab :: b -> IO [Either b a] -> IO [Either b a]
189emitSymTab x io = do xs <- unsafeInterleaveIO io
190                     return (Left x:xs)
191