{-# 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