hsenv-0.5: src/Args.hs

{-# LANGUAGE Arrows, CPP #-}

module Args (getArgs) where

import Control.Arrow
import Data.Char
import Util.Args
import Types

#ifdef cabal
import Util.Cabal (prettyVersion)
import Paths_hsenv (version)

versionString :: String
versionString = prettyVersion version
#else
versionString :: String
versionString = "dev"
#endif

verbosityOpt, veryVerbosityOpt, skipSanityOpt, sharingOpt, noPS1Opt :: Switch

verbosityOpt = Switch { switchName  = "verbose"
                      , switchHelp  = "Print some debugging info"
                      , switchShort = Just 'v'
                      }

veryVerbosityOpt = Switch { switchName  = "very-verbose"
                          , switchHelp  = "Print some more debugging info"
                          , switchShort = Nothing
                          }

skipSanityOpt = Switch { switchName  = "skip-sanity-check"
                       , switchHelp  = "Skip all the sanity checks (use at your own risk)"
                       , switchShort = Nothing
                       }

sharingOpt = Switch { switchName  = "dont-share-cabal-cache"
                    , switchHelp  = "Don't share ~/.cabal/packages (hackage download cache)"
                    , switchShort = Nothing
                    }

noPS1Opt =
    Switch { switchName = "no-ps1-indicator"
           , switchHelp =
               "Don't modify the shell prompt to indicate the current hsenv"
           , switchShort = Nothing
           }

nameOpt, ghcOpt :: DynOpt

nameOpt = DynOpt
          { dynOptName = "name"
          , dynOptTemplate = "NAME"
          , dynOptDescription = "current directory name"
          , dynOptHelp = "Use NAME as name of the Virtual Haskell Environment"
          }

ghcOpt = DynOpt
         { dynOptName = "ghc"
         , dynOptTemplate = "VERSION|URL|FILE"
         , dynOptDescription = "system's copy of GHC"
         , dynOptHelp =
             "Use GHC from provided location -- a GHC version number, an HTTP or HTTPS URL or a path to a tarball (e.g. ghc-7.0.4-i386-unknown-linux.tar.bz2)"
         }

makeOpt :: StaticOpt
makeOpt = StaticOpt
          { staticOptName = "make-cmd"
          , staticOptTemplate = "CMD"
          , staticOptDefault = "make"
          , staticOptHelp =
              "Used as make substitute for installing GHC from tarball (e.g. gmake)"
          }

argParser :: ArgArrow () Options
argParser = proc () -> do
  verbosityFlag <- getOpt verbosityOpt -< ()
  verbosityFlag2 <- getOpt veryVerbosityOpt -< ()
  let verboseness = case (verbosityFlag, verbosityFlag2) of
                      (_, True)      -> VeryVerbose
                      (True, False)  -> Verbose
                      (False, False) -> Quiet
  name <- getOpt nameOpt -< ()
  ghcFlag <- getOpt ghcOpt -< ()
  noPS1' <- getOpt noPS1Opt -< ()
  let ghc = case ghcFlag of
              Nothing   -> System
              -- First check for URLs (@//@ is not meaningful in Posix file
              -- paths), then versions and then default to path.
              Just s | "https://" == take 8 s -> Url s
                     | "http://"  == take 7 s -> Url s
                     | isVersion s            -> Release s
                     | otherwise              -> Tarball s
  skipSanityCheckFlag <- getOpt skipSanityOpt -< ()
  noSharingFlag <- getOpt sharingOpt -< ()
  make <- getOpt makeOpt -< ()
  returnA -< Options{ verbosity       = verboseness
                   , skipSanityCheck = skipSanityCheckFlag
                   , hsEnvName       = name
                   , ghcSource       = ghc
                   , makeCmd         = make
                   , noSharing       = noSharingFlag
                   , noPS1           = noPS1'
                   }

getArgs :: IO Options
getArgs = parseArgs argParser versionString outro
  where
    outro = "Creates Virtual Haskell Environment in the current directory.\n"
         ++ "All files will be stored in the .hsenv[_NAME]/ subdirectory.\n"
         ++ "\n"
         ++ "To activate a sandbox in the current directory, run:\n"
         ++ "\n"
         ++ "    source .hsenv/bin/activate\n"
         ++ "\n"
         ++ "To deactivate an active sandbox, run:\n"
         ++ "\n"
         ++ "    deactivate_hsenv"

isVersion :: String -> Bool
isVersion s = case dropWhile isDigit s of
                ""     -> s /= ""
                '.':s' -> s /= '.':s' && isVersion s'
                _      -> False