content: -----------------------------------------------------------------------------
  -- |
  -- 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 -> IO [(Posn,String)]
    ) where
  
  
  import Text.Parse
  import Language.Preprocessor.Cpphs.SymTab
  import Language.Preprocessor.Cpphs.Position  (Posn,newfile,newline,newlines
                                               ,cppline,cpp2hask,newpos)
  import Language.Preprocessor.Cpphs.ReadFirst (readFirst)
  import Language.Preprocessor.Cpphs.Tokenise  (linesCpp,reslash)
  import Language.Preprocessor.Cpphs.Options   (BoolOptions(..), CpphsActions (..))
  import Language.Preprocessor.Cpphs.HashDefine(HashDefine(..),parseHashDefine
                                               ,expandMacro)
  import Language.Preprocessor.Cpphs.MacroPass (preDefine,defineMacro)
  import Data.Char        (isDigit,isSpace,isAlphaNum)
  import Data.List        (intercalate,isPrefixOf)
  import Numeric          (readHex,readOct,readDec)
  import System.IO.Unsafe (unsafeInterleaveIO)
  import Control.Monad    (when)
  
  -- | 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 :: CpphsActions
          -> 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
          -> IO [(Posn,String)]   -- ^ The file after processing (in lines)
  cppIfdef actions fp syms search options =
      cpp actions posn defs search options (Keep []) . initial . linesCpp
    where
      posn = newfile fp
      defs = preDefine options syms
      initial = if literate options then id else (cppline posn:)
  -- 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 ps@, @n@ is the depth of nesting, @b@ is whether
  --   we have already succeeded in keeping some lines in a chain of
  --   @elif@'s, and @ps@ is the stack of positions of open @#if@ contexts,
  --   used for error messages in case EOF is reached too soon.
  data KeepState = Keep [Posn] | Drop Int Bool [Posn]
  
  -- | Return just the list of lines that the real cpp would decide to keep.
  cpp :: CpphsActions
         -> Posn -> SymTab HashDefine -> [String] -> BoolOptions -> KeepState
         -> [String] -> IO [(Posn,String)]
  
  cpp actions _p _syms _path _options (Keep ps) [] | not (null ps) = do
      cpphsPutWarning actions $
                        "Unmatched #if: positions of open context are:\n"++
                         unlines (map show ps)
      return []
  cpp _actions _p _syms _path _options _keep [] = return []
  
  cpp actions p syms path options (Keep ps) (l@('#':x):xs) =
      let ws = words x
          cmd = if null ws then "" else head ws
          line = if null ws then [] else tail ws
          sym  = if null line then "" else head line
          rest = if null line then [] else tail line
          def = defineMacro options (sym++" "++ maybe "1" id (un rest))
          un v = if null v then Nothing else Just (unwords v)
          keepIf b = if b then Keep (p:ps) else Drop 1 False (p:ps)
          skipn syms' retain ud xs' =
              let n = 1 + length (filter (=='\n') l) in
              (if macros options && retain then emitOne  (p,reslash l)
                                           else emitMany (replicate n (p,""))) $
              cpp actions (newlines n p) syms' path options ud xs'
      in case cmd of
          "define" -> skipn (insertST def syms) True (Keep ps) xs
          "undef"  -> skipn (deleteST sym syms) True (Keep ps) xs
          "ifndef" -> skipn syms False (keepIf (not (definedST sym syms))) xs
          "ifdef"  -> skipn syms False (keepIf      (definedST sym syms)) xs
          "if"     -> do b <- gatherDefined actions p syms (unwords line)
                         skipn syms False (keepIf b) xs
          "else"   -> skipn syms False (Drop 1 False ps) xs
          "elif"   -> skipn syms False (Drop 1 True ps) xs
          "endif"  | null ps ->
                      do cpphsPutWarning actions $ "Unmatched #endif at "++show p
                         return []
          "endif"  -> skipn syms False (Keep (tail ps)) xs
          "pragma" -> skipn syms True  (Keep ps) xs
          ('!':_)  -> skipn syms False (Keep ps) xs       -- \#!runhs scripts
          "include"-> do (inc,content) <- readFirst actions
                                                    (file syms (unwords line))
                                                    p path
                                                    (warnings options)
                         cpp actions p syms path options (Keep ps)
                               (("#line 1 "++show inc): linesCpp content
                                                      ++ cppline (newline p): xs)
          "warning"-> if warnings options then
                        do cpphsPutWarning actions (l++"\nin "++show p)
                           skipn syms False (Keep ps) xs
                      else skipn syms False (Keep ps) xs
          "error"  -> cpphsDie actions (l++"\nin "++show p)
          "line"   | all isDigit sym
                   -> (if locations options && hashline options then emitOne (p,l)
                       else if locations options then emitOne (p,cpp2hask l)
                       else id) $
                      cpp actions (newpos (read sym) (un rest) p)
                          syms path options (Keep ps) xs
          n | all isDigit n && not (null n)
                   -> (if locations options && hashline options then emitOne (p,l)
                       else if locations options then emitOne (p,cpp2hask l)
                       else id) $
                      cpp actions (newpos (read n) (un (tail ws)) p)
                          syms path options (Keep ps) xs
            | otherwise
                   -> do when (warnings options) $
                             cpphsPutWarning actions ("Warning: unknown directive #"++n
                                               ++"\nin "++show p)
                         emitOne (p,l) $
                                 cpp actions (newline p) syms path options (Keep ps) xs
  
  cpp actions p syms path options (Drop n b ps) (('#':x):xs) =
      let ws = words x
          cmd = if null ws then "" else head ws
          delse    | n==1 && b = Drop 1 b ps
                   | n==1      = Keep ps
                   | otherwise = Drop n b ps
          dend     | n==1      = Keep (tail ps)
                   | otherwise = Drop (n-1) b (tail ps)
          delif v  | n==1 && not b && v
                               = Keep ps
                   | otherwise = Drop n b ps
          skipn ud xs' =
                   let n' = 1 + length (filter (=='\n') x) in
                   emitMany (replicate n' (p,"")) $
                      cpp actions (newlines n' p) syms path options ud xs'
      in
      if      cmd == "ifndef" ||
              cmd == "if"     ||
              cmd == "ifdef" then    skipn (Drop (n+1) b (p:ps)) xs
      else if cmd == "elif"  then do v <- gatherDefined actions p syms (unwords (tail ws))
                                     skipn (delif v) xs
      else if cmd == "else"  then    skipn  delse xs
      else if cmd == "endif" then
              if null ps then do cpphsPutWarning actions $ "Unmatched #endif at "++show p
                                 return []
                         else skipn  dend  xs
      else skipn (Drop n b ps) xs
          -- define, undef, include, error, warning, pragma, line
  
  cpp actions p syms path options (Keep ps) (x:xs) =
      let p' = newline p in seq p' $
      emitOne (p,x)  $  cpp actions p' syms path options (Keep ps) xs
  cpp actions p syms path options d@(Drop _ _ _) (_:xs) =
      let p' = newline p in seq p' $
      emitOne (p,"") $  cpp actions p' syms path options d xs
  
  
  -- | Auxiliary IO functions
  emitOne  ::  a  -> IO [a] -> IO [a]
  emitMany :: [a] -> IO [a] -> IO [a]
  emitOne  x  io = do ys <- unsafeInterleaveIO io
                      return (x:ys)
  emitMany xs io = do ys <- unsafeInterleaveIO io
                      return (xs++ys)
  
  
  ----
  gatherDefined :: CpphsActions -> Posn -> SymTab HashDefine -> String -> IO Bool
  gatherDefined actions p st inp =
    case runParser (preExpand st) inp of
      (Left msg, _) -> cpphsDie actions ("Cannot expand #if directive in file "++show p
                             ++":\n    "++msg)
      (Right s, xs) -> do
  --      cpphsPutWarning actions $ "Expanded #if at "++show p++" is:\n  "++s
          when (any (not . isSpace) xs) $
               cpphsPutWarning actions ("Warning: trailing characters after #if"
                                ++" macro expansion in file "++show p++": "++xs)
  
          case runParser parseBoolExp s of
            (Left msg, _) -> cpphsDie actions ("Cannot parse #if directive in file "++show p
                                   ++":\n    "++msg)
            (Right b, xs) -> do when (any (not . isSpace) xs && notComment xs) $
                                     cpphsPutWarning actions
                                       ("Warning: trailing characters after #if"
                                        ++" directive in file "++show p++": "++xs)
                                return b
  
  notComment = not . ("//"`isPrefixOf`) . dropWhile isSpace
  
  
  -- | The preprocessor must expand all macros (recursively) before evaluating
  --   the conditional.
  preExpand :: SymTab HashDefine -> TextParser String
  preExpand st =
    do  eof
        return ""
    <|>
    do  a <- many1 (satisfy notIdent)
        commit $ pure (a++) `apply` preExpand st
    <|>
    do  b <- expandSymOrCall st
        commit $ pure (b++) `apply` preExpand st
  
  -- | Expansion of symbols.
  expandSymOrCall :: SymTab HashDefine -> TextParser String
  expandSymOrCall st =
    do sym <- parseSym
       if sym=="defined" then do arg <- skip parseSym; convert sym [arg]
                              <|>
                              do arg <- skip $ parenthesis (do x <- skip parseSym;
                                                               skip (return x))
                                 convert sym [arg]
                              <|> convert sym []
        else
        ( do  args <- parenthesis (commit $ fragment `sepBy` skip (isWord ","))
              args' <- flip mapM args $ \arg->
                           case runParser (preExpand st) arg of
                               (Left msg, _) -> fail msg
                               (Right s, _)  -> return s
              convert sym args'
          <|> convert sym []
        )
    where
      fragment = many1 (satisfy (`notElem`",)"))
      convert "defined" [arg] =
        case lookupST arg st of
          Nothing | all isDigit arg    -> return arg 
          Nothing                      -> return "0"
          Just (a@AntiDefined{})       -> return "0"
          Just (a@SymbolReplacement{}) -> return "1"
          Just (a@MacroExpansion{})    -> return "1"
      convert sym args =
        case lookupST sym st of
          Nothing  -> if null args then return sym
                      else return "0"
                   -- else fail (disp sym args++" is not a defined macro")
          Just (a@SymbolReplacement{}) -> do reparse (replacement a)
                                             return ""
          Just (a@MacroExpansion{})    -> do reparse (expandMacro a args False)
                                             return ""
          Just (a@AntiDefined{})       ->
                      if null args then return sym
                      else return "0"
                   -- else fail (disp sym args++" explicitly undefined with -U")
      disp sym args = let len = length args
                          chars = map (:[]) ['a'..'z']
                      in sym ++ if null args then ""
                                else "("++intercalate "," (take len chars)++")"
  
  parseBoolExp :: TextParser Bool
  parseBoolExp =
    do  a <- parseExp1
        bs <- many (do skip (isWord "||")
                       commit $ skip parseBoolExp)
        return $ foldr (||) a bs
  
  parseExp1 :: TextParser Bool
  parseExp1 =
    do  a <- parseExp0
        bs <- many (do skip (isWord "&&")
                       commit $ skip parseExp1)
        return $ foldr (&&) a bs
  
  parseExp0 :: TextParser Bool
  parseExp0 =
    do  skip (isWord "!")
        a <- commit $ parseExp0
        return (not a)
    <|>
    do  val1 <- parseArithExp1
        op   <- parseCmpOp
        val2 <- parseArithExp1
        return (val1 `op` val2)
    <|>
    do  sym <- parseArithExp1
        case sym of
          0 -> return False
          _ -> return True
    <|>
    do  parenthesis (commit parseBoolExp)
  
  parseArithExp1 :: TextParser Integer
  parseArithExp1 =
    do  val1 <- parseArithExp0
        ( do op   <- parseArithOp1
             val2 <- parseArithExp1
             return (val1 `op` val2)
          <|> return val1 )
    <|>
    do  parenthesis parseArithExp1
  
  parseArithExp0 :: TextParser Integer
  parseArithExp0 =
    do  val1 <- parseNumber
        ( do op   <- parseArithOp0
             val2 <- parseArithExp0
             return (val1 `op` val2)
          <|> return val1 )
    <|>
    do  parenthesis parseArithExp0
  
  parseNumber :: TextParser Integer
  parseNumber = fmap safeRead $ skip parseSym
    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
  
  parseCmpOp :: TextParser (Integer -> Integer -> Bool)
  parseCmpOp =
    do  skip (isWord ">=")
        return (>=)
    <|>
    do  skip (isWord ">")
        return (>)
    <|>
    do  skip (isWord "<=")
        return (<=)
    <|>
    do  skip (isWord "<")
        return (<)
    <|>
    do  skip (isWord "==")
        return (==)
    <|>
    do  skip (isWord "!=")
        return (/=)
  
  parseArithOp1 :: TextParser (Integer -> Integer -> Integer)
  parseArithOp1 =
    do  skip (isWord "+")
        return (+)
    <|>
    do  skip (isWord "-")
        return (-)
  
  parseArithOp0 :: TextParser (Integer -> Integer -> Integer)
  parseArithOp0 =
    do  skip (isWord "*")
        return (*)
    <|>
    do  skip (isWord "/")
        return (div)
    <|>
    do  skip (isWord "%")
        return (rem)
  
  -- | Return the expansion of the symbol (if there is one).
  parseSymOrCall :: SymTab HashDefine -> TextParser String
  parseSymOrCall st =
    do  sym <- skip parseSym
        args <- parenthesis (commit $ parseSymOrCall st `sepBy` skip (isWord ","))
        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{})    -> recursivelyExpand st (expandMacro a args False)
          Just (a@AntiDefined{})       -> name a
  
  recursivelyExpand :: SymTab HashDefine -> String -> String
  recursivelyExpand st inp =
    case runParser (parseSymOrCall st) inp of
      (Left msg, _) -> inp
      (Right s,  _) -> s
  
  parseSym :: TextParser String
  parseSym = many1 (satisfy (\c-> isAlphaNum c || c`elem`"'`_"))
             `onFail`
             do xs <- allAsString
                fail $ "Expected an identifier, got \""++xs++"\""
  
  notIdent :: Char -> Bool
  notIdent c = not (isAlphaNum c || c`elem`"'`_")
  
  skip :: TextParser a -> TextParser a
  skip p = many (satisfy isSpace) >> p
  
  -- | The standard "parens" parser does not work for us here.  Define our own.
  parenthesis :: TextParser a -> TextParser a
  parenthesis p = do isWord "("
                     x <- p
                     isWord ")"
                     return x
  
  -- | 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
  
  