-----------------------------------------------------------------------------
-- |
-- 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
  , 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 Data.Time.Clock  (getCurrentTime)
import Data.Time.Format (formatTime)
import TimeCompat       (defaultTimeLocale)

noPos :: Posn
noPos :: Posn
noPos = String -> Posn
newfile String
"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
          -> IO String          -- ^ The file after processing
macroPass :: [(String, String)] -> BoolOptions -> [(Posn, String)] -> IO String
macroPass [(String, String)]
syms BoolOptions
options =
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall {a}. [a] -> [a]
safetail              -- to remove extra "\n" inserted below
         forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
         forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. [Either a b] -> [b]
onlyRights)
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool
-> Bool
-> Bool
-> SymTab HashDefine
-> [WordStyle]
-> IO [Either (SymTab HashDefine) String]
macroProcess (BoolOptions -> Bool
pragma BoolOptions
options) (BoolOptions -> Bool
layout BoolOptions
options) (BoolOptions -> Bool
lang BoolOptions
options)
                   (BoolOptions -> [(String, String)] -> SymTab HashDefine
preDefine BoolOptions
options [(String, String)]
syms)
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> Bool -> Bool -> Bool -> [(Posn, String)] -> [WordStyle]
tokenise (BoolOptions -> Bool
stripEol BoolOptions
options) (BoolOptions -> Bool
stripC89 BoolOptions
options)
               (BoolOptions -> Bool
ansi BoolOptions
options) (BoolOptions -> Bool
lang BoolOptions
options)
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Posn
noPos,String
"")forall a. a -> [a] -> [a]
:)     -- ensure recognition of "\n#" at start of file
  where
    safetail :: [a] -> [a]
safetail [] = []
    safetail (a
_:[a]
xs) = [a]
xs

-- | auxiliary
onlyRights :: [Either a b] -> [b]
onlyRights :: forall a b. [Either a b] -> [b]
onlyRights = forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (\Either a b
x->case Either a b
x of Right b
t-> [b
t]; Left a
_-> [];)

-- | Walk through the document, replacing calls of macros with the expanded RHS.
--   Additionally returns the active symbol table after processing.
macroPassReturningSymTab
          :: [(String,String)]  -- ^ Pre-defined symbols and their values
          -> BoolOptions        -- ^ Options that alter processing style
          -> [(Posn,String)]    -- ^ The input file content
          -> IO (String,[(String,String)])
                                -- ^ The file and symbol table after processing
macroPassReturningSymTab :: [(String, String)]
-> BoolOptions
-> [(Posn, String)]
-> IO (String, [(String, String)])
macroPassReturningSymTab [(String, String)]
syms BoolOptions
options =
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall {t} {a} {b}. (t -> a) -> (t, b) -> (a, b)
mapFst (forall {a}. [a] -> [a]
safetail              -- to remove extra "\n" inserted below
                 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat)
         forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {a}.
[Either (SymTab HashDefine) a] -> ([a], [(String, String)])
walk)
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool
-> Bool
-> Bool
-> SymTab HashDefine
-> [WordStyle]
-> IO [Either (SymTab HashDefine) String]
macroProcess (BoolOptions -> Bool
pragma BoolOptions
options) (BoolOptions -> Bool
layout BoolOptions
options) (BoolOptions -> Bool
lang BoolOptions
options)
                   (BoolOptions -> [(String, String)] -> SymTab HashDefine
preDefine BoolOptions
options [(String, String)]
syms)
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> Bool -> Bool -> Bool -> [(Posn, String)] -> [WordStyle]
tokenise (BoolOptions -> Bool
stripEol BoolOptions
options) (BoolOptions -> Bool
stripC89 BoolOptions
options)
               (BoolOptions -> Bool
ansi BoolOptions
options) (BoolOptions -> Bool
lang BoolOptions
options)
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Posn
noPos,String
"")forall a. a -> [a] -> [a]
:)     -- ensure recognition of "\n#" at start of file
  where
    safetail :: [a] -> [a]
safetail [] = []
    safetail (a
_:[a]
xs) = [a]
xs
    walk :: [Either (SymTab HashDefine) a] -> ([a], [(String, String)])
walk (Right a
x: [Either (SymTab HashDefine) a]
rest) = let ([a]
xs,   [(String, String)]
foo) = [Either (SymTab HashDefine) a] -> ([a], [(String, String)])
walk [Either (SymTab HashDefine) a]
rest
                           in  (a
xforall a. a -> [a] -> [a]
:[a]
xs, [(String, String)]
foo)
    walk (Left  SymTab HashDefine
x: [])   =     ( [] , [HashDefine] -> [(String, String)]
simplifyHashDefines (forall v. SymTab v -> [v]
flattenST SymTab HashDefine
x) )
    walk (Left  SymTab HashDefine
x: [Either (SymTab HashDefine) a]
rest) = [Either (SymTab HashDefine) a] -> ([a], [(String, String)])
walk [Either (SymTab HashDefine) a]
rest
    mapFst :: (t -> a) -> (t, b) -> (a, b)
mapFst t -> a
f (t
a,b
b) = (t -> a
f t
a, b
b)


-- | Turn command-line definitions (from @-D@) into 'HashDefine's.
preDefine :: BoolOptions -> [(String,String)] -> SymTab HashDefine
preDefine :: BoolOptions -> [(String, String)] -> SymTab HashDefine
preDefine BoolOptions
options [(String, String)]
defines =
    forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (forall v. (String, v) -> SymTab v -> SymTab v
insertST forall b c a. (b -> c) -> (a -> b) -> a -> c
. BoolOptions -> String -> (String, HashDefine)
defineMacro BoolOptions
options forall b c a. (b -> c) -> (a -> b) -> a -> c
. (\ (String
s,String
d)-> String
sforall a. [a] -> [a] -> [a]
++String
" "forall a. [a] -> [a] -> [a]
++String
d))
          forall v. SymTab v
emptyST [(String, String)]
defines

-- | Turn a string representing a macro definition into a 'HashDefine'.
defineMacro :: BoolOptions -> String -> (String,HashDefine)
defineMacro :: BoolOptions -> String -> (String, HashDefine)
defineMacro BoolOptions
opts String
s =
    let (Cmd (Just HashDefine
hd):[WordStyle]
_) = Bool -> Bool -> Bool -> Bool -> [(Posn, String)] -> [WordStyle]
tokenise Bool
True Bool
True (BoolOptions -> Bool
ansi BoolOptions
opts) (BoolOptions -> Bool
lang BoolOptions
opts)
                                     [(Posn
noPos,String
"\n#define "forall a. [a] -> [a] -> [a]
++String
sforall a. [a] -> [a] -> [a]
++String
"\n")]
    in (HashDefine -> String
name HashDefine
hd, HashDefine
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?)
--   The result lazily intersperses output text with symbol tables.  Lines
--   are emitted as they are encountered.  A symbol table is emitted after
--   each change to the defined symbols, and always at the end of processing.
macroProcess :: Bool -> Bool -> Bool -> SymTab HashDefine -> [WordStyle]
             -> IO [Either (SymTab HashDefine) String]
macroProcess :: Bool
-> Bool
-> Bool
-> SymTab HashDefine
-> [WordStyle]
-> IO [Either (SymTab HashDefine) String]
macroProcess Bool
_ Bool
_ Bool
_ SymTab HashDefine
st        []          = forall (m :: * -> *) a. Monad m => a -> m a
return [forall a b. a -> Either a b
Left SymTab HashDefine
st]
macroProcess Bool
p Bool
y Bool
l SymTab HashDefine
st (Other String
x: [WordStyle]
ws)      = forall a b. a -> IO [Either b a] -> IO [Either b a]
emit String
x    forall a b. (a -> b) -> a -> b
$ Bool
-> Bool
-> Bool
-> SymTab HashDefine
-> [WordStyle]
-> IO [Either (SymTab HashDefine) String]
macroProcess Bool
p Bool
y Bool
l SymTab HashDefine
st [WordStyle]
ws
macroProcess Bool
p Bool
y Bool
l SymTab HashDefine
st (Cmd Maybe HashDefine
Nothing: [WordStyle]
ws)  = forall a b. a -> IO [Either b a] -> IO [Either b a]
emit String
"\n" forall a b. (a -> b) -> a -> b
$ Bool
-> Bool
-> Bool
-> SymTab HashDefine
-> [WordStyle]
-> IO [Either (SymTab HashDefine) String]
macroProcess Bool
p Bool
y Bool
l SymTab HashDefine
st [WordStyle]
ws
macroProcess Bool
p Bool
y Bool
l SymTab HashDefine
st (Cmd (Just (LineDrop String
x)): [WordStyle]
ws)
                                         = forall a b. a -> IO [Either b a] -> IO [Either b a]
emit String
"\n" forall a b. (a -> b) -> a -> b
$
                                           forall a b. a -> IO [Either b a] -> IO [Either b a]
emit String
x    forall a b. (a -> b) -> a -> b
$ Bool
-> Bool
-> Bool
-> SymTab HashDefine
-> [WordStyle]
-> IO [Either (SymTab HashDefine) String]
macroProcess Bool
p Bool
y Bool
l SymTab HashDefine
st [WordStyle]
ws
macroProcess Bool
pragma Bool
y Bool
l SymTab HashDefine
st (Cmd (Just (Pragma String
x)): [WordStyle]
ws)
               | Bool
pragma    = forall a b. a -> IO [Either b a] -> IO [Either b a]
emit String
"\n" forall a b. (a -> b) -> a -> b
$ forall a b. a -> IO [Either b a] -> IO [Either b a]
emit String
x forall a b. (a -> b) -> a -> b
$ Bool
-> Bool
-> Bool
-> SymTab HashDefine
-> [WordStyle]
-> IO [Either (SymTab HashDefine) String]
macroProcess Bool
pragma Bool
y Bool
l SymTab HashDefine
st [WordStyle]
ws
               | Bool
otherwise = forall a b. a -> IO [Either b a] -> IO [Either b a]
emit String
"\n" forall a b. (a -> b) -> a -> b
$          Bool
-> Bool
-> Bool
-> SymTab HashDefine
-> [WordStyle]
-> IO [Either (SymTab HashDefine) String]
macroProcess Bool
pragma Bool
y Bool
l SymTab HashDefine
st [WordStyle]
ws
macroProcess Bool
p Bool
layout Bool
lang SymTab HashDefine
st (Cmd (Just HashDefine
hd): [WordStyle]
ws) =
    let n :: Int
n = Int
1 forall a. Num a => a -> a -> a
+ HashDefine -> Int
linebreaks HashDefine
hd
        newST :: SymTab HashDefine
newST = forall v. (String, v) -> SymTab v -> SymTab v
insertST (HashDefine -> String
name HashDefine
hd, HashDefine
hd) SymTab HashDefine
st
    in
    forall a b. a -> IO [Either b a] -> IO [Either b a]
emit (forall a. Int -> a -> [a]
replicate Int
n Char
'\n') forall a b. (a -> b) -> a -> b
$
    forall b a. b -> IO [Either b a] -> IO [Either b a]
emitSymTab SymTab HashDefine
newST forall a b. (a -> b) -> a -> b
$
    Bool
-> Bool
-> Bool
-> SymTab HashDefine
-> [WordStyle]
-> IO [Either (SymTab HashDefine) String]
macroProcess Bool
p Bool
layout Bool
lang SymTab HashDefine
newST [WordStyle]
ws
macroProcess Bool
pr Bool
layout Bool
lang SymTab HashDefine
st (Ident Posn
p String
x: [WordStyle]
ws) =
    case String
x of
      String
"__FILE__" -> forall a b. a -> IO [Either b a] -> IO [Either b a]
emit (forall a. Show a => a -> String
show (Posn -> String
filename Posn
p))forall a b. (a -> b) -> a -> b
$ Bool
-> Bool
-> Bool
-> SymTab HashDefine
-> [WordStyle]
-> IO [Either (SymTab HashDefine) String]
macroProcess Bool
pr Bool
layout Bool
lang SymTab HashDefine
st [WordStyle]
ws
      String
"__LINE__" -> forall a b. a -> IO [Either b a] -> IO [Either b a]
emit (forall a. Show a => a -> String
show (Posn -> Int
lineno Posn
p))  forall a b. (a -> b) -> a -> b
$ Bool
-> Bool
-> Bool
-> SymTab HashDefine
-> [WordStyle]
-> IO [Either (SymTab HashDefine) String]
macroProcess Bool
pr Bool
layout Bool
lang SymTab HashDefine
st [WordStyle]
ws
      String
"__DATE__" -> do String
w <- forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
.
                         -- formatCalendarTime defaultTimeLocale "\"%d %b %Y\""
                         -- =<< toCalendarTime =<< getClockTime
                            forall t. FormatTime t => TimeLocale -> String -> t -> String
formatTime TimeLocale
defaultTimeLocale String
"\"%d %b %Y\""
                            forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IO UTCTime
getCurrentTime
                       forall a b. a -> IO [Either b a] -> IO [Either b a]
emit String
w forall a b. (a -> b) -> a -> b
$ Bool
-> Bool
-> Bool
-> SymTab HashDefine
-> [WordStyle]
-> IO [Either (SymTab HashDefine) String]
macroProcess Bool
pr Bool
layout Bool
lang SymTab HashDefine
st [WordStyle]
ws
      String
"__TIME__" -> do String
w <- forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
.
                         -- formatCalendarTime defaultTimeLocale "\"%H:%M:%S\""
                         -- =<< toCalendarTime =<< getClockTime
                            forall t. FormatTime t => TimeLocale -> String -> t -> String
formatTime TimeLocale
defaultTimeLocale String
"\"%H:%M:%S\""
                            forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IO UTCTime
getCurrentTime
                       forall a b. a -> IO [Either b a] -> IO [Either b a]
emit String
w forall a b. (a -> b) -> a -> b
$ Bool
-> Bool
-> Bool
-> SymTab HashDefine
-> [WordStyle]
-> IO [Either (SymTab HashDefine) String]
macroProcess Bool
pr Bool
layout Bool
lang SymTab HashDefine
st [WordStyle]
ws
      String
_ ->
        case forall v. String -> SymTab v -> Maybe v
lookupST String
x SymTab HashDefine
st of
            Maybe HashDefine
Nothing -> forall a b. a -> IO [Either b a] -> IO [Either b a]
emit String
x forall a b. (a -> b) -> a -> b
$ Bool
-> Bool
-> Bool
-> SymTab HashDefine
-> [WordStyle]
-> IO [Either (SymTab HashDefine) String]
macroProcess Bool
pr Bool
layout Bool
lang SymTab HashDefine
st [WordStyle]
ws
            Just HashDefine
hd ->
                case HashDefine
hd of
                    AntiDefined {name :: HashDefine -> String
name=String
n} -> forall a b. a -> IO [Either b a] -> IO [Either b a]
emit String
n forall a b. (a -> b) -> a -> b
$
                                            Bool
-> Bool
-> Bool
-> SymTab HashDefine
-> [WordStyle]
-> IO [Either (SymTab HashDefine) String]
macroProcess Bool
pr Bool
layout Bool
lang SymTab HashDefine
st [WordStyle]
ws
                    SymbolReplacement {replacement :: HashDefine -> String
replacement=String
r} ->
                        let r' :: String
r' = if Bool
layout then String
r else forall a. (a -> Bool) -> [a] -> [a]
filter (forall a. Eq a => a -> a -> Bool
/=Char
'\n') String
r in
                        -- one-level expansion only:
                        -- emit r' $ macroProcess layout st ws
                        -- multi-level expansion:
                        Bool
-> Bool
-> Bool
-> SymTab HashDefine
-> [WordStyle]
-> IO [Either (SymTab HashDefine) String]
macroProcess Bool
pr Bool
layout Bool
lang SymTab HashDefine
st
                                     (Bool -> Bool -> Bool -> Bool -> [(Posn, String)] -> [WordStyle]
tokenise Bool
True Bool
True Bool
False Bool
lang [(Posn
p,String
r')]
                                      forall a. [a] -> [a] -> [a]
++ [WordStyle]
ws)
                    MacroExpansion {} ->
                        case Posn -> [WordStyle] -> Maybe ([[WordStyle]], [WordStyle])
parseMacroCall Posn
p [WordStyle]
ws of
                            Maybe ([[WordStyle]], [WordStyle])
Nothing -> forall a b. a -> IO [Either b a] -> IO [Either b a]
emit String
x forall a b. (a -> b) -> a -> b
$
                                       Bool
-> Bool
-> Bool
-> SymTab HashDefine
-> [WordStyle]
-> IO [Either (SymTab HashDefine) String]
macroProcess Bool
pr Bool
layout Bool
lang SymTab HashDefine
st [WordStyle]
ws
                            Just ([[WordStyle]]
args,[WordStyle]
ws') ->
                                if forall (t :: * -> *) a. Foldable t => t a -> Int
length [[WordStyle]]
args forall a. Eq a => a -> a -> Bool
/= forall (t :: * -> *) a. Foldable t => t a -> Int
length (HashDefine -> [String]
arguments HashDefine
hd) then
                                     forall a b. a -> IO [Either b a] -> IO [Either b a]
emit String
x forall a b. (a -> b) -> a -> b
$ Bool
-> Bool
-> Bool
-> SymTab HashDefine
-> [WordStyle]
-> IO [Either (SymTab HashDefine) String]
macroProcess Bool
pr Bool
layout Bool
lang SymTab HashDefine
st [WordStyle]
ws
                                else do [String]
args' <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concatforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall a b. [Either a b] -> [b]
onlyRights)
                                                       forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool
-> Bool
-> Bool
-> SymTab HashDefine
-> [WordStyle]
-> IO [Either (SymTab HashDefine) String]
macroProcess Bool
pr Bool
layout
                                                                        Bool
lang SymTab HashDefine
st)
                                                      [[WordStyle]]
args
                                        -- one-level expansion only:
                                        -- emit (expandMacro hd args' layout) $
                                        --         macroProcess layout st ws'
                                        -- multi-level expansion:
                                        Bool
-> Bool
-> Bool
-> SymTab HashDefine
-> [WordStyle]
-> IO [Either (SymTab HashDefine) String]
macroProcess Bool
pr Bool
layout Bool
lang SymTab HashDefine
st
                                            (Bool -> Bool -> Bool -> Bool -> [(Posn, String)] -> [WordStyle]
tokenise Bool
True Bool
True Bool
False Bool
lang
                                               [(Posn
p,HashDefine -> [String] -> Bool -> String
expandMacro HashDefine
hd [String]
args' Bool
layout)]
                                            forall a. [a] -> [a] -> [a]
++ [WordStyle]
ws')

-- | Useful helper function.
emit :: a -> IO [Either b a] -> IO [Either b a]
emit :: forall a b. a -> IO [Either b a] -> IO [Either b a]
emit a
x IO [Either b a]
io = do [Either b a]
xs <- forall a. IO a -> IO a
unsafeInterleaveIO IO [Either b a]
io
               forall (m :: * -> *) a. Monad m => a -> m a
return (forall a b. b -> Either a b
Right a
xforall a. a -> [a] -> [a]
:[Either b a]
xs)
-- | Useful helper function.
emitSymTab :: b -> IO [Either b a] -> IO [Either b a]
emitSymTab :: forall b a. b -> IO [Either b a] -> IO [Either b a]
emitSymTab b
x IO [Either b a]
io = do [Either b a]
xs <- forall a. IO a -> IO a
unsafeInterleaveIO IO [Either b a]
io
                     forall (m :: * -> *) a. Monad m => a -> m a
return (forall a b. a -> Either a b
Left b
xforall a. a -> [a] -> [a]
:[Either b a]
xs)