content: {-# LANGUAGE GeneralizedNewtypeDeriving #-}
  module Args ( usage
              , parseArgs
              ) where
  
  import System.Directory (getCurrentDirectory)
  import Data.List (isPrefixOf, isInfixOf)
  import Data.Char (isAlphaNum)
  import Data.Maybe (fromMaybe)
  import Control.Monad (when)
  import Data.Monoid (Monoid(..))
  import System.Environment (getProgName)
  import System.FilePath (splitPath)
  import Control.Monad.Error (MonadError, ErrorT, runErrorT, throwError)
  import Control.Monad.State (MonadState, StateT, runStateT, get, put)
  import Control.Monad.Trans (MonadIO, liftIO)
  
  import Types
  
  usage :: IO ()
  usage = do
      name <- getProgName
      putStrLn $ "usage: " ++ name ++ " [FLAGS]"
      putStrLn ""
      putStrLn "Flags:"
      putStrLn "-h --help           Show this help message"
      putStrLn "--version           Print version number"
      putStrLn "--verbose           Print some debugging info"
      putStrLn "--very-verbose      Print some debugging info"
      putStrLn "--skip-sanity-check Skip all the sanity checks (use at your own risk)"
      putStrLn "--name=NAME         Use NAME for name of Virthual Haskell Environment"
      putStrLn "                    (defaults to the name of the current directory)"
      putStrLn "--ghc=FILE          Use GHC from provided tarball (e.g. ghc-7.0.4-i386-unknown-linux.tar.bz2)"
      putStrLn "                    Without this flag virthualenv will use system's copy of GHC"
      putStrLn "--make-cmd=NAME     Used as make substitute for installing GHC from tarball (e.g. gmake),"
      putStrLn "                    defaults to 'make'"
      putStrLn ""
      putStrLn "Creates Virtual Haskell Environment in the current directory."
      putStrLn "All files will be stored in the .virthualenv/ subdirectory."
  
  newtype ArgMonad a = ArgMonad (ErrorT String (StateT Args IO) a)
      deriving (MonadState Args, MonadError String, Monad, MonadIO)
  
  data Args = Args { shortArgs      :: [Char]
                   , longArgs       :: [String]
                   , longValArgs    :: [(String, String)]
                   , positionalArgs :: [String]
                   }
      deriving Show
  
  emptyArgs :: Args
  emptyArgs = Args [] [] [] []
  
  instance Monoid Args where
      mempty = Args [] [] [] []
      Args x1 y1 z1 t1 `mappend` Args x2 y2 z2 t2 = Args (x1 ++ x2) (y1 ++ y2) (z1 ++ z2) (t1 ++ t2)
  
  runArgMonad :: ArgMonad a -> [String] -> IO (Either String a)
  runArgMonad (ArgMonad m) args =
      case parseArguments args of
        Left err         -> return $ Left err
        Right parsedArgs -> do
          (result, leftOverArgs) <- runStateT (runErrorT m) parsedArgs
          case leftOverArgs of
            Args [] [] [] [] -> return result
            Args shortOptions _ _ _ | not (null shortOptions) ->
              return $ Left $ "Unknown short option identifiers: " ++ shortOptions
            Args _ longOptions _ _  | not (null longOptions) ->
              return $ Left $ "Unknown long option identifiers: " ++ unwords longOptions
            Args _ _ longKeyValOptions _ | not (null longKeyValOptions) ->
              return $ Left $ "Unknown long key-value options: " ++ unwords (map (\(k,v) -> k++"="++v) longKeyValOptions)
            Args _ _ _ _ -> return $ Left $ "Unknown positional options: " ++ unwords (positionalArgs leftOverArgs)
  
  parseArguments :: [String] -> Either String Args
  parseArguments args =
      case break (== "--") args of
        (keywordArgs, "--":rest) -> do
          parsedKeywordArgs <- mapM parseArgument keywordArgs
          return $ mconcat parsedKeywordArgs `mappend` emptyArgs{positionalArgs = rest}
  
        (_, []) -> mconcat `fmap` mapM parseArgument args
        _ -> error "I'm stupid and I cannot code. I'm sorry."
  
  parseArgument :: String -> Either String Args
  parseArgument arg | "--" `isPrefixOf` arg
                    && "="  `isInfixOf` arg =
                        let (x, y) = break (=='=') arg
                            key = drop (length "--") x
                            val = drop (length "=")  y
                        in return emptyArgs{longValArgs = [(key, val)]}
                    | "--" `isPrefixOf` arg =
                        return emptyArgs{longArgs = [drop (length "--") arg]}
                    | "-" `isPrefixOf` arg =
                        let symbols = tail arg
                        in case symbols of
                             [] -> throwError "Empty list of short options (after '-')"
                             _ | any (not . isAlphaNum) symbols -> throwError "Non alpha-numeric short option"
                               | otherwise -> return emptyArgs{shortArgs = symbols}
                    | otherwise = return emptyArgs{positionalArgs = [arg]}
  
  getSingleLongValueArg :: String -> ArgMonad (Maybe String)
  getSingleLongValueArg argName = do
    args <- get
    case filter (\(k,_) -> k == argName) $ longValArgs args of
      [] -> return Nothing
      [(_, val)] -> do
        put args{longValArgs = filter (\(k,_) -> k /= argName) $ longValArgs args}
        return $ Just val
      _ -> throwError $ "Multiple values with key " ++ argName
  
  isSingleValueSet :: String -> ArgMonad Bool
  isSingleValueSet argName = do
    args <- get
    case filter (==argName) $ longArgs args of
      [] -> return False
      [_] -> do
        put args{longArgs = filter (/=argName) $ longArgs args}
        return True
      _ -> throwError $ "Multiple values named " ++ argName
  
  realParseArgs :: ArgMonad Options
  realParseArgs = do
    verbosityFlag  <- isSingleValueSet "verbose"
    verbosityFlag2 <- isSingleValueSet "very-verbose"
    let verboseness = case (verbosityFlag, verbosityFlag2) of
                        (_, True)      -> VeryVerbose
                        (True, False)  -> Verbose
                        (False, False) -> Quiet
    nameFlag <- getSingleLongValueArg "name"
    name <- case nameFlag of
             Just name' -> return name'
             Nothing    -> do
               cwd <- liftIO getCurrentDirectory
               let dirs = splitPath cwd
                   name = last dirs
               when (verboseness > Quiet) $ liftIO $ putStrLn $ "Using current directory name as Virtual Haskell Environment name: " ++ name
               return name
    ghcFlag <- getSingleLongValueArg "ghc"
    let ghc = case ghcFlag of
                Nothing   -> System
                Just path -> Tarball path
    skipSanityCheckFlag <- isSingleValueSet "skip-sanity-check"
    makeCmdFlag <- getSingleLongValueArg "make-cmd"
    let make = fromMaybe "make" makeCmdFlag
    return Options{ verbosity = verboseness
                  , skipSanityCheck = skipSanityCheckFlag
                  , vheName   = name
                  , ghcSource = ghc
                  , makeCmd   = make
                  }
  
  parseArgs :: [String] -> IO (Either String Options)
  parseArgs = runArgMonad realParseArgs
  