content: {-# LANGUAGE PatternGuards #-}
  -----------------------------------------------------------------------------
  -- |
  -- Module      :  Language.C.System.Gcc
  -- Copyright   :  (c) 2008 Benedikt Huber
  -- License     :  BSD-style
  -- Maintainer  :  benedikt.huber@gmail.com
  -- Stability   :  experimental
  -- Portability :  portable
  --
  -- Invoking gcc for preprocessing and compiling.
  -----------------------------------------------------------------------------
  module Language.C.System.GCC (
      GCC,newGCC,
  )
  where
  import Language.C.Data.RList as RList
  import Language.C.System.Preprocess
  import Data.Maybe
  import System.Process
  import System.Directory
  import Data.List
  
  -- | @GCC@ represents a reference to the gcc compiler
  newtype GCC = GCC { gccPath :: FilePath }
  
  -- | create a reference to @gcc@
  newGCC :: FilePath -> GCC
  newGCC = GCC
  
  instance Preprocessor GCC where
      parseCPPArgs _ = gccParseCPPArgs
      runCPP gcc cpp_args =
          do  -- copy the input to the outputfile, because in case the input is preprocessed,
              -- gcc -E will do nothing.
              maybe (return()) (copyWritable (inputFile cpp_args)) (outputFile cpp_args)
              rawSystem (gccPath gcc) (buildCppArgs cpp_args)
                  where copyWritable source target = do copyFile source target
                                                        p <- getPermissions target
                                                        setPermissions target p{writable=True}
  
  -- | Parse arguments for preprocessing via GCC.
  --   At least one .c, .hc or .h file has to be present.
  --   For now we only support the most important gcc options.
  --
  --   1) Parse all flags relevant to CppArgs
  --   2) Move -c,-S,-M? to other_args
  --   3) Strip -E
  --   4) The rest goes into extra_args
  gccParseCPPArgs :: [String] -> Either String (CppArgs, [String])
  gccParseCPPArgs args =
      case mungeArgs ((Nothing,Nothing,RList.empty),(RList.empty,RList.empty)) args of
          Left err                   -> Left err
          Right ((Nothing,_,_),_)  -> Left "No .c / .hc / .h source file given"
          Right ((Just input_file,output_file_opt,cpp_opts),(extra_args,other_args))
              -> Right ((rawCppArgs (RList.reverse extra_args) input_file)
                        { outputFile = output_file_opt, cppOptions = RList.reverse cpp_opts },
                        RList.reverse other_args)
      where
      mungeArgs :: ParseArgsState -> [String] -> Either String ParseArgsState
      mungeArgs parsed@( cpp_args@(inp,out,cpp_opts),
                            unparsed@(extra,other))
                unparsed_args =
          case unparsed_args of
              ("-E":rest) -> mungeArgs parsed rest
  
              (flag:rest) |  flag == "-c"
                          || flag == "-S"
                          || "-M" `isPrefixOf` flag
                          -> mungeArgs (cpp_args,(extra,other `snoc` flag)) rest
  
              ("-o":file:rest)   | isJust out -> Left "two output files given"
                                 | otherwise          -> mungeArgs ((inp,Just file,cpp_opts),unparsed) rest
  
              (cpp_opt:rest)     | Just (opt,rest') <- getArgOpt cpp_opt rest
                                 -> mungeArgs ((inp,out,cpp_opts `snoc` opt),unparsed) rest'
  
              (cfile:rest)       | any (flip isSuffixOf cfile) (words ".c .hc .h")
                                 -> if isJust inp
                                     then Left "two input files given"
                                     else mungeArgs ((Just cfile,out,cpp_opts),unparsed) rest
  
              (unknown:rest)     -> mungeArgs (cpp_args,(extra `snoc` unknown,other)) rest
  
              []                 -> Right parsed
  
      getArgOpt cpp_opt rest | "-I" `isPrefixOf` cpp_opt = Just (IncludeDir (drop 2 cpp_opt),rest)
                             | "-U" `isPrefixOf` cpp_opt = Just (Undefine (drop 2 cpp_opt),rest)
                             | "-D" `isPrefixOf` cpp_opt = Just (getDefine (drop 2 cpp_opt),rest)
      getArgOpt "-include" (f:rest')                     = Just (IncludeFile f, rest')
      getArgOpt _ _ = Nothing
      getDefine opt = let (key,val) = break (== '=') opt in Define key (if null val then "" else tail val)
  
  type ParseArgsState = ((Maybe FilePath, Maybe FilePath, RList CppOption), (RList String, RList String))
  
  
  buildCppArgs :: CppArgs -> [String]
  buildCppArgs (CppArgs options extra_args _tmpdir input_file output_file_opt) = do
         (concatMap tOption options)
      ++ outputFileOpt
      ++ ["-E", input_file]
      ++ extra_args
      where
      tOption (IncludeDir incl)  = ["-I",incl]
      tOption (Define key value) = [ "-D" ++ key ++ (if null value then "" else "=" ++ value) ]
      tOption (Undefine key)     = [ "-U" ++ key ]
      tOption (IncludeFile f)    = [ "-include", f]
      outputFileOpt = concat [ ["-o",output_file] | output_file <- maybeToList output_file_opt ]
  
  