-----------------------------------------------------------------------------
-- |
-- 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 test generator program.
--
-----------------------------------------------------------------------------

module Tests.Exec.CmdArgs where

import WinDll.Session.Hs2lib
import Tests.Exec.Version
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
         : optTempDir
         : optVersion
         : optHelp
         : 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 ""  "debug"                (\cfg new -> cfg { debugging           = new })  ("Enable debugging support which enabled memory profiling.")
           
-- | 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 ++ "\")")
optTempDir        = Option [   ] ["temp","temp-directory"    ] (ReqArg (\value cfg -> cfg { tempDIR   = value }) "<temp-directory>")                "set the temporary directory of the pre-processor (Default system temp)"
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"
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 ()