-----------------------------------------------------------------------------
-- |
-- Module      :  Windll
-- Copyright   :  (c) Tamar Christina 2009 - 2010
-- License     :  BSD3
-- 
-- Maintainer  :  tamar@zhox.com
-- Stability   :  experimental
-- Portability :  portable
--
-- A module to handle commandline arguments and parsing
-- for the main program.
--
-----------------------------------------------------------------------------

module WinDll.CmdArgs.Hs2lib where

import WinDll.Session.Hs2lib
import WinDll.Version.Hs2lib
import WinDll.Utils.Feedback
import WinDll.Structs.Structures
import WinDll.Utils.Pragma

import System.Directory
import System.Environment
import System.FilePath
import System.Console.GetOpt
import System.Exit

import Data.Maybe
import Data.Char
import Data.List

import Control.Monad

-- | just renaming it to something that might make more sense to read in this module
type Config = Session  
                     
-- | Default configuration set for both the client and server.
defaultConfig :: Mode -> Config
defaultConfig Windows = newSession 
defaultConfig Unix    = let session = newSession 
                        in session { call = CCall }
                     

-- | The parse mode for processArgs
type Mode = Platform

-- | Read all the pragmas that contain options and then update the session with the new flags
enablePragmas :: Exec ()
enablePragmas =
 do session <- get
    inform _normal "Enabling commandline pragmas..."
    let prgmas   = (pragmas.workingset) session
        cmds     = getPragmas (upper_name ++ "_OPTS") prgmas
        args     = mainFile session : concatMap (\(Pragma _ x)->x) cmds
        mode     = platform session
    
    session' <- processConversionPragmas prgmas session
    (result,errs) <- if (null args) then return (session',[]) else
         liftIO $ do (result,errs) <- processArgs session' mode args
                     if (not.null) errs then putStrLn "  Error(s):" else do return ()
                     mapM_ (\i -> putStrLn ("  -> unrecognized input '"++i++"')")) errs
                     return (result,errs)
    if null errs 
       then put result 
       else die "Error processing dynamic options"

-- | Process args tries to parse the commandline arguments for either the client or the server.                       
-- 1 = The session to initialize things with
-- 2 = Mode to parse for
-- 3 = arguments to parse
-- return = Parsed config or error message
processArgs :: Config -> Mode -> [String] -> IO (Config, [String])
processArgs cfg mode argv= 
       case getOpt Permute opt argv of
          (o,n,[]) -> process (foldl (flip id) cfg o) n opt
          (_,_,errs) -> ioError (userError (concat errs ++ usageInfo header opt))
      where header = "Usage: " ++ name ++ " <input file> [OPTION...]"
            name  = if mode == Windows then exename ++ ".exe" else exename
            opt   = optDescr --if mode == Windows then optDescrClient else optDescrServer
            process a r opt = 
                case Help `elem` opts of
                    True -> ioError (userError $ usageInfo header opt)
                    False -> case Version `elem` opts of
                        True -> putStrLn versionmsg >> exitSuccess
                                
                        False -> case r of
                                   (x:[]) -> do path     <- canonicalizePath (addTrailingPathSeparator (tempDIR a))
                                                base     <- getCurrentDirectory
                                                abs_path <- guessPath x
                                                let dir = takeDirectory (normalise x)
                                                    bin = combine base dir
                                                return (a { mainFile = x
                                                          , platform = mode
                                                          , tempDIR  = path 
                                                          , absPath  = abs_path
                                                          , baseDir  = base
                                                          },[])
                                   _ -> ioError (userError $ usageInfo header opt)
               where opts = options a
      
-- | Create a boolean flag
boolFlag :: String -> String -> (a->Bool->a) -> String -> [OptDescr (a->a)]
boolFlag short long update descr =  [ template (update' True) short long  descr
                                    , template (update' False) "" ("no"++long) [] ]
 where
    template value short long descr = Option short [long] (NoArg value) descr
    update' = flip update
    
-- | Collection of options available
optDescr = optVerbose
         : optCall 
         : optNamespace
         : optHackageBaseURL
         : optOutDir
         : optTempDir
         : optOutFile
         : optPlatform
         : optVersion
         : optHelp
         : optLibmain
         : optIncludes
         : optGhc
         : boolFlag "W" "warnings"             (\cfg new -> cfg { warnings           = new })  "print all warnings (Default True)"
        ++ boolFlag "E" "warnings-as-errors"   (\cfg new -> cfg { warnings_as_errors = new
                                                          , warnings = new || warnings cfg })  "treat all warnings as errors (Default False)"
        ++ boolFlag "T" "keep-temp-files"      (\cfg new -> cfg { keep_temps         = new })  "keep all the temporary files generated by the pre-processor (Default False)"
        ++ boolFlag ""  "c#"                   (\cfg new -> cfg { csharp             = new })  "enable C# file output"
        ++ boolFlag ""  "cpp"                  (\cfg new -> cfg { cpp                = new })  "enable C/C++ file output (default True)"
        ++ boolFlag "M" "lib"                  (\cfg new -> cfg { mvcpp              = new })  "create a .LIB file for use with the Microsoft Visual C++ compiler. NOTE: This requires the %VSBIN% (case sensitive) environment variable to be set."
        ++ boolFlag "d" "incl-def"             (\cfg new -> cfg { incDef             = new })  "Copy the generated .DEF file also to the specified output folder."
        ++ boolFlag ""  "link-dyn"             (\cfg new -> cfg { link_dynamic       = new })  ("If you have the dynamic version of all your libs installed you can use this flag. (this includes having installed " ++ exename ++ " using -dynamic)")
        ++ boolFlag ""  "debug"                (\cfg new -> cfg { debugging          = new })  ("Enable debugging support which enabled memory profiling.")
        ++ boolFlag ""  "preserve-comments"    (\cfg new -> cfg { pres_comment       = new })  "Enabling this allows you to preserve the haddock description comments of your functions in the generated C _FFI file (Default True)"
        ++ boolFlag ""  "preserve-foreigns"    (\cfg new -> cfg { include_foreigns   = new })  ("Enabling this will preserve and re-export any foreign declarations you already have declared in modules. NOTE: The Naming Convention must be the same as the generated functions. " ++ exename ++ " finds. (Default True)")
        ++ boolFlag ""  "no-dllmain"           (\cfg new -> cfg { dllmanual          = new })  "Enabling this will allow you to manual initialise the RTS. Dllmain will no longer make the call to HsInit(). -L and --libmain will be ignored. (Default True)"
        ++ boolFlag ""  "threaded"             (\cfg new -> cfg { threaded           = new 
                                                   , dllmanual = new || dllmanual cfg      })  "Enable the threaded RTS. This implies --no-dllmain. (Default False)"
           
-- | Collection of simple actions
optVerbose        = Option ['v'] ["verbose","verbosity"      ] (OptArg (\value cfg -> cfg { verbosity        = fread (verbosity cfg) value  }) "<number>") "set the verbosity level. Requires a number between 0 (off) and 3"
optCall           = Option ['C'] ["convention"               ] (ReqArg (\value cfg -> cfg { call             = cread StdCall value }) "<StdCall | CCall>") "set the calling convention used in FFI (Default stdcall)"
optNamespace      = Option ['n'] ["name"                     ] (ReqArg (\value cfg -> cfg { namespace        = correct value }) "<name>")                  ("set the name to use in every generated code. (Default \"" ++ exename ++ "\")")
optHackageBaseURL = Option ['h'] ["hackage-base-url"         ] (ReqArg (\value cfg -> cfg { hackage_base_url = value }) "<base-url>")                      "set the Hackage base url which will be used when doing code discovery"
optOutDir         = Option [   ] ["outdir","output-directory"] (ReqArg (\value cfg -> cfg { outputDIR        = value }) "<output-directory>")              "set the output directory of the pre-processor (Default current folder)"
optTempDir        = Option [   ] ["temp","temp-directory"    ] (ReqArg (\value cfg -> cfg { tempDIR          = value }) "<temp-directory>")                "set the temporary directory of the pre-processor (Default system temp)"
optOutFile        = Option ['o'] ["out","outFile"            ] (ReqArg (\value cfg -> cfg { outputFile       = value }) "<output-file>")                   "set the name of the output file (Default derived from input and platform)"
optPlatform       = Option ['P'] ["platform"                 ] (ReqArg (\value cfg -> cfg { platform         = cread Windows value }) "<Windows | Unix>")  "set the platform to compile for (Defaul current system)"
optIncludes       = Option ['I'] ["includes"                 ] (ReqArg (\value cfg -> cfg { includes         = value : (includes cfg) }) "file")           "include extra files in the pipeline. (external definitions)"
optHelp           = Option ['?'] ["h","help"                 ] (NoArg  (\cfg -> cfg {options                 = Help:(options cfg)}) )                      "Show this help screen"
optVersion        = Option [   ] ["version"                  ] (NoArg  (\cfg -> cfg {options                 = Version:(options cfg)}) )                   "Show program version information"
optLibmain        = Option ['L'] ["libmain"                  ] (ReqArg (\value cfg -> cfg { dllmain          = value }) "<path>")                          "set the dllmain file to be used by when compiling the library"
optIncForeign     = Option [   ] ["native-symbols"           ] (ReqArg (\value cfg -> cfg { native_symbols   = value : (native_symbols cfg) }) "<path>")    "include the .DEF file specified here into the final generated Exports table."
optGhc            = Option [   ] ["opt-ghc"                  ] (ReqArg (\value cfg -> cfg { optGHC            = value }) "\"<options>\"")    "options to pass along unmodified to ghc during main compilation."

fread :: Int -> Maybe String -> Int
fread c q = let p = maybe 1 (read' 1) q
            in if (p + c) > 3 || (c + p) < 0 then 1 else (c+p)
          
cread c q = let p = reads q
                hasValue = not $ null p
                value = if hasValue then fst $ head p else c
            in value
            
-- | Get the read in namespace name into a useable format
correct :: String -> String
correct [] = []
correct (x:xs) = toUpper x : filter isAlphaNum xs

-- | Because read can fail for parsing stuff other than strings. 
-- this function is used to either accept the change. or use the default
read' :: Int -> String -> Int
read' def str = let r = reads str                       
                   in if null r then def else (fst.head) r

-- | The main parse function to call. It takes a mode as parameters and takes a pointer
-- to a function to call should it all succeed.
goArgs :: Mode -> (Config -> IO ()) -> IO ()
goArgs mode call =
  do args <- getArgs
     (result,errs) <- processArgs (defaultConfig mode) mode args
     if (not.null) errs then putStrLn "  Errors:" else do return ()
     mapM_ (\i -> putStrLn ("  -> unrecognized input '"++i++"')")) errs
     if null errs then call result else do return ()