virthualenv (empty) → 0.2
raw patch · 21 files changed
+1461/−0 lines, 21 filesdep +Cabaldep +basedep +bytestringsetup-changed
Dependencies added: Cabal, base, bytestring, directory, file-embed, filepath, mtl, process, safe, split
Files
- LICENSE +30/−0
- README.md +154/−0
- Setup.hs +2/−0
- skeletons/activate +52/−0
- skeletons/cabal +25/−0
- skeletons/cabal_config +9/−0
- src/Actions.hs +206/−0
- src/Args.hs +153/−0
- src/MyMonad.hs +87/−0
- src/PackageManagement.hs +103/−0
- src/Paths.hs +45/−0
- src/Process.hs +108/−0
- src/SanityCheck.hs +63/−0
- src/Skeletons.hs +16/−0
- src/Types.hs +42/−0
- src/Util/Cabal.hs +39/−0
- src/Util/IO.hs +81/−0
- src/Util/Template.hs +22/−0
- src/virthualenv.hs +55/−0
- virthualenv.cabal +127/−0
- virthualenv.el +42/−0
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c)2011, Bartosz Ćwikłowski++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the name of Bartosz Ćwikłowski nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ README.md view
@@ -0,0 +1,154 @@+Virtual Haskell Environment+===========================++What is it?+-----------+virthualenv is a tool (inspired by Python's virtualenv)+to create isolated Haskell environments.+++What does it do?+----------------+It creates a sandboxed environment in a .virthualenv/ sub-directory+of your project, which, when activated, allows you to use regular Haskell tools+(ghc, ghci, ghc-pkg, cabal) to manage your Haskell code and environment.+It's possible to create an environment, that uses different GHC version+than your currently installed. Very simple emacs integration mode is included.++Basic usage+-----------+First, choose a directory where you want to keep your+sandboxed Haskell environment, usually a good choice is a directory containing+your cabalized project (if you want to work on a few projects+(perhaps an app and its dependent library), just choose any of them,+it doesn't really matter). Enter that directory:++> cd ~/projects/foo++Next, create your new isolated Haskell environment+(this is a one time only (per environment) step):++> virthualenv++Now, every time you want to use this environment, you have to activate it:++> source .virthualenv/bin/activate++That's it! Now it's possible to use all regular Haskell tools like usual,+but it won't affect your global/system's Haskell environment, and also+your per-user environment (from ~/.cabal and ~/.ghc) will stay the same.+All cabal-installed packages will be private to this environment,+and also the external environments (global and user) will not affect it+(this environment will only inherit very basic packages,+mostly ghc and Cabal and their deps).++When you're done working with this environment, enter command 'deactivate',+or just close the current shell (with exit).++> deactivate++Advanced usage+--------------+Here's the most advanced usage of virthualenv. Let's say you want to:++* hack on json library+* do so comfortably+* use your own version of parsec library+* and do all this using nightly version of GHC++First, download binary distribution of GHC for your platform+(e.g. ghc-7.3.20111105-i386-unknown-linux.tar.bz2).++Create a directory for you environment:++> mkdir /tmp/test; cd /tmp/test++Then, create a new environment using that GHC:++> virthualenv --ghc=/path/to/ghc-7.3.20111105-i386-unknown-linux.tar.bz2++Activate it:++> source .virthualenv/bin/activate++Download a copy of json library and your private version of parsec:++> darcs get http://patch-tag.com/r/Paczesiowa/parsec; cabal unpack json++Install parsec:++> cd parsec2; cabal install++Install the rest of json deps:++> cd ../json-0.5; cabal install --only-dependencies++Now, let's say you want to hack on Parsec module of json library.+Open it in emacs:++> emacsclient Text/JSON/Parsec.hs++Activate the virtual environment (virthualenv must be required earlier):++> M-x virthualenv-activate <RET> /tmp/test/ <RET>++Edit some code and load it in ghci using 'C-c C-l'. If it type checks,+you can play around with the code using nightly version of ghci running+in your virtual environment. When you're happy with the code, exit emacs+and install your edited json library:++> cabal install++And that's it.++Misc+----+virthualenv has been tested on i386 Linux and FreeBSD systems,+but it should work on any Posix platform. External (from tarball) GHC feature+requires binary GHC distribution compiled for your platform,+that can be extracted with tar and installed with+"./configure --prefix=PATH; make install".++FAQ+---+Q: Can I use it together with tools like cabal-dev or capri? +A: No. All these tools work more or less the same (wrapping cabal command,+ setting GHC_PACKAGE_PATH env variable), so something will probably break.++Q: Using GHC from tarball fails, when using FreeBSD with a bunch of make tool + gibberish. What do I do? +A: Try '--make-cmd=gmake' switch.++Q: Can I use virthualenv inside virthualenv? +A: No. It may be supported in future versions.++Q: Does it work on x64 systems? +A: It hasn't been tested, but there's no reason why it shouldn't.++Q: Will it work on Mac? +A: I doubt it. It should be easy to make it work there with system's GHC,+ Using GHC from tarball will be probably harder. I don't have any mac+ machines, so you're on your own, but patches/ideas/questions are welcome.++Q: Will it work on Windows? +A: I really doubt it would even compile. I don't have access to any windows+ machines, so you're on your own, but patches/ideas/questions are welcome.+ Maybe it would work on cygwin.++Q: Does it require bash? +A: No, it should work with any POSIX-compliant shell. It's been tested with+ bash, bash --posix, dash, zsh and ksh.++Q: Can I use it with a different haskell package repository than hackage? +A: Yes, just adjust the url in .virthualenv/cabal/config file.++Q: How do I remove the whole virtual environment? +A: If it's activated - 'deactivate' it. Then, delete+ the .virthualenv/ directory.++Q: Is every environment completely separate from other environments and+ the system environment? +A: Yes. The only (minor) exception is ghci history - there's only one+ per user history file. Also, if you alter your system's GHC, then+ virtual environments using system's GHC copy will probably break.+ Virtual environments using GHC from a tarball should continue to work.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ skeletons/activate view
@@ -0,0 +1,52 @@+if [ -n "${VIRTHUALENV}" ]; then+ if [ "<VIRTHUALENV>" = "${VIRTHUALENV}" ]; then+ echo "${VIRTHUALENV_NAME} Virtual Haskell Environment is already active."+ else+ echo "There is already ${VIRTHUALENV_NAME} Virtual Haskell Environment activated."+ echo "Deactivate it first (using command 'deactivate'), to activate"+ echo "<VIRTHUALENV_NAME> environment."+ fi+ return 1+fi++export VIRTHUALENV="<VIRTHUALENV>"+export VIRTHUALENV_NAME="<VIRTHUALENV_NAME>"++echo "Activating ${VIRTHUALENV_NAME} Virtual Haskell Environment (at ${VIRTHUALENV})."+echo ""+echo "Use regular Haskell tools (ghc, ghci, ghc-pkg, cabal) to manage your Haskell environment."+echo ""+echo "To exit from this virtual environment, enter command 'deactivate'."++export "VIRTHUALENV_PATH_BACKUP"="${PATH}"+export "VIRTHUALENV_PS1_BACKUP"="${PS1}"++deactivate() {+ echo "Deactivating ${VIRTHUALENV_NAME} Virtual Haskell Environment (at ${VIRTHUALENV})."+ echo "Restoring previous environment settings."++ export "PATH"="${VIRTHUALENV_PATH_BACKUP}"+ unset -v "VIRTHUALENV_PATH_BACKUP"+ export "PS1"="${VIRTHUALENV_PS1_BACKUP}"+ unset -v "VIRTHUALENV_PS1_BACKUP"++ unset -v VIRTHUALENV+ unset -v VIRTHUALENV_NAME+ unset -v GHC_PACKAGE_PATH+ unset -f deactivate++ if [ -n "$BASH" -o -n "$ZSH_VERSION" ]; then+ hash -r+ fi+}++PATH_PREPENDIX="$(cat <VIRTHUALENV_DIR>/path_var_prependix)"+export PATH="${PATH_PREPENDIX}:${PATH}"+unset -v PATH_PREPENDIX++export GHC_PACKAGE_PATH="$(cat <VIRTHUALENV_DIR>/ghc_package_path_var)"+export PS1="(${VIRTHUALENV_NAME})${PS1}"++if [ -n "$BASH" -o -n "$ZSH_VERSION" ]; then+ hash -r+fi
+ skeletons/cabal view
@@ -0,0 +1,25 @@+#!/bin/sh++PATH_ELEMS="$(echo ${PATH} | tr -s ':' '\n')"++ORIG_CABAL_BINARY=""++for PATH_ELEM in ${PATH_ELEMS}; do+ CABAL_CANDIDATE="${PATH_ELEM}/cabal"+ if command -v "${CABAL_CANDIDATE}" > /dev/null 2> /dev/null; then+ if [ "${0}" != "${CABAL_CANDIDATE}" ]; then+ if [ -z "${ORIG_CABAL_BINARY}" ]; then+ ORIG_CABAL_BINARY="${CABAL_CANDIDATE}"+ fi+ fi+ fi+done++if [ -z "${ORIG_CABAL_BINARY}" ]; then+ echo "cabal wrapper: Couldn't find real cabal program"+ exit 1+fi++CABAL_CONFIG="<CABAL_CONFIG>"++exec "${ORIG_CABAL_BINARY}" --config-file="${CABAL_CONFIG}" "${@}"
+ skeletons/cabal_config view
@@ -0,0 +1,9 @@+remote-repo: hackage.haskell.org:http://hackage.haskell.org/packages/archive+remote-repo-cache: <CABAL_DIR>/packages+logs-dir: <CABAL_DIR>/logs+world-file: <CABAL_DIR>/world+package-db: <GHC_PACKAGE_PATH>+build-summary: <CABAL_DIR>/logs/build.log+remote-build-reporting: anonymous+install-dirs user+ prefix: <CABAL_DIR>
+ src/Actions.hs view
@@ -0,0 +1,206 @@+module Actions ( cabalUpdate+ , installCabalConfig+ , installCabalWrapper+ , installActivateScript+ , copyBaseSystem+ , initGhcDb+ , installGhc+ , createDirStructure+ ) where++import System.Directory (setCurrentDirectory, getCurrentDirectory, createDirectory, removeDirectoryRecursive)+import System.FilePath ((</>))+import Distribution.Version (Version (..))+import Distribution.Package (PackageName(..))+import Safe (lastMay)+import Data.List (intercalate)++import MyMonad+import Types+import Paths+import PackageManagement+import Process+import Util.Template (substs)+import Util.IO (makeExecutable, createTemporaryDirectory)+import Skeletons++-- update cabal package info inside Virtual Haskell Environmentn+cabalUpdate :: MyMonad ()+cabalUpdate = do+ env <- getVirtualEnvironment+ cabalConfig <- cabalConfigLocation+ info "Updating cabal package database inside Virtual Haskell Environment."+ _ <- indentMessages $ runProcess (Just env) "cabal" ["--config-file=" ++ cabalConfig, "update"] Nothing+ return ()++-- install cabal wrapper (in bin/ directory) inside virtual environment dir structure+installCabalWrapper :: MyMonad ()+installCabalWrapper = do+ cabalConfig <- cabalConfigLocation+ dirStructure <- vheDirStructure+ let cabalWrapper = virthualEnvBinDir dirStructure </> "cabal"+ info $ concat [ "Installing cabal wrapper using "+ , cabalConfig+ , " at "+ , cabalWrapper+ ]+ let cabalWrapperContents = substs [("<CABAL_CONFIG>", cabalConfig)] cabalWrapperSkel+ indentMessages $ do+ trace "cabal wrapper contents:"+ indentMessages $ mapM_ trace $ lines cabalWrapperContents+ liftIO $ writeFile cabalWrapper cabalWrapperContents+ liftIO $ makeExecutable cabalWrapper++installActivateScriptSupportFiles :: MyMonad ()+installActivateScriptSupportFiles = do+ debug "installing supporting files"+ dirStructure <- vheDirStructure+ ghc <- asks ghcSource+ indentMessages $ do+ let pathVarPrependixLocation = virthualEnvDir dirStructure </> "path_var_prependix"+ pathVarElems =+ case ghc of+ System -> [virthualEnvBinDir dirStructure, cabalBinDir dirStructure]+ Tarball _ -> [ virthualEnvBinDir dirStructure+ , cabalBinDir dirStructure+ , ghcBinDir dirStructure+ ]+ pathVarPrependix = intercalate ":" pathVarElems+ debug $ "installing path_var_prependix file to " ++ pathVarPrependixLocation+ indentMessages $ trace $ "path_var_prependix contents: " ++ pathVarPrependix+ liftIO $ writeFile pathVarPrependixLocation pathVarPrependix+ ghcPkgDbPath <- indentMessages ghcPkgDbPathLocation+ let ghcPackagePathVarLocation = virthualEnvDir dirStructure </> "ghc_package_path_var"+ ghcPackagePathVar = ghcPkgDbPath+ debug $ "installing ghc_package_path_var file to " ++ ghcPackagePathVarLocation+ indentMessages $ trace $ "path_var_prependix contents: " ++ ghcPackagePathVar+ liftIO $ writeFile ghcPackagePathVarLocation ghcPackagePathVar++-- install activate script (in bin/ directory) inside virtual environment dir structure+installActivateScript :: MyMonad ()+installActivateScript = do+ info "Installing activate script"+ virthualEnvName <- asks vheName+ dirStructure <- vheDirStructure+ ghcPkgDbPath <- indentMessages ghcPkgDbPathLocation+ let activateScript = virthualEnvBinDir dirStructure </> "activate"+ indentMessages $ debug $ "using location: " ++ activateScript+ let activateScriptContents = substs [ ("<VIRTHUALENV_NAME>", virthualEnvName)+ , ("<VIRTHUALENV_DIR>", virthualEnvDir dirStructure)+ , ("<VIRTHUALENV>", virthualEnv dirStructure)+ , ("<GHC_PACKAGE_PATH>", ghcPkgDbPath)+ , ("<VIRTHUALENV_BIN_DIR>", virthualEnvBinDir dirStructure)+ , ("<CABAL_BIN_DIR>", cabalBinDir dirStructure)+ , ("<GHC_BIN_DIR>", ghcBinDir dirStructure)+ ] activateSkel+ indentMessages $ do+ trace "activate script contents:"+ indentMessages $ mapM_ trace $ lines activateScriptContents+ liftIO $ writeFile activateScript activateScriptContents+ indentMessages installActivateScriptSupportFiles++-- install cabal's config file (in cabal/ directory) inside virtual environment dir structure+installCabalConfig :: MyMonad ()+installCabalConfig = do+ cabalConfig <- cabalConfigLocation+ dirStructure <- vheDirStructure+ info $ "Installing cabal config at " ++ cabalConfig+ let cabalConfigContents = substs [ ("<GHC_PACKAGE_PATH>", ghcPackagePath dirStructure)+ , ("<CABAL_DIR>", cabalDir dirStructure)+ ] cabalConfigSkel+ indentMessages $ do+ trace "cabal config contents:"+ indentMessages $ mapM_ trace $ lines cabalConfigContents+ liftIO $ writeFile cabalConfig cabalConfigContents++createDirStructure :: MyMonad ()+createDirStructure = do+ dirStructure <- vheDirStructure+ info "Creating Virtual Haskell directory structure"+ indentMessages $ do+ debug $ "virthualenv directory: " ++ virthualEnvDir dirStructure+ liftIO $ createDirectory $ virthualEnvDir dirStructure+ debug $ "cabal directory: " ++ cabalDir dirStructure+ liftIO $ createDirectory $ cabalDir dirStructure+ debug $ "virthualenv bin directory: " ++ virthualEnvBinDir dirStructure+ liftIO $ createDirectory $ virthualEnvBinDir dirStructure++-- initialize private GHC package database inside virtual environment+initGhcDb :: MyMonad ()+initGhcDb = do+ dirStructure <- vheDirStructure+ info $ "Initializing GHC Package database at " ++ ghcPackagePath dirStructure+ out <- indentMessages $ outsideGhcPkg ["--version"]+ case lastMay $ words out of+ Nothing -> throwError $ MyException $ "Couldn't extract ghc-pkg version number from: " ++ out+ Just versionString -> do+ indentMessages $ trace $ "Found version string: " ++ versionString+ version <- parseVersion versionString+ let ghc_6_12_1_version = Version [6,12,1] []+ if version < ghc_6_12_1_version then do+ indentMessages $ debug "Detected GHC older than 6.12, initializing GHC_PACKAGE_PATH to file with '[]'"+ liftIO $ writeFile (ghcPackagePath dirStructure) "[]"+ else do+ _ <- indentMessages $ outsideGhcPkg ["init", ghcPackagePath dirStructure]+ return ()++-- copy optional packages and don't fail completely if this copying fails+-- some packages mail fail to copy and it's not fatal (e.g. older GHCs don't have haskell2010)+transplantOptionalPackage :: String -> MyMonad ()+transplantOptionalPackage name = transplantPackage (PackageName name) `catchError` handler+ where handler e = do+ warning $ "Failed to copy optional package " ++ name ++ " from system's GHC: "+ indentMessages $ warning $ getExceptionMessage e++-- copy base system+-- base - needed for ghci and everything else+-- Cabal - needed to install non-trivial cabal packages with cabal-install+-- haskell98 - some packages need it but they don't specify it (seems it's an implicit dependancy)+-- haskell2010 - maybe it's similar to haskell98?+-- ghc and ghc-binary - two packages that are provided with GHC and cannot be installed any other way+-- also include dependant packages of all the above+-- when using GHC from tarball, just reuse its package database+-- cannot do the same when using system's GHC, because there might be additional packages installed+-- then it wouldn't be possible to work on them insie virtual environment+copyBaseSystem :: MyMonad ()+copyBaseSystem = do+ info "Copying necessary packages from original GHC package database"+ indentMessages $ do+ ghc <- asks ghcSource+ case ghc of+ System -> do+ transplantPackage $ PackageName "base"+ transplantPackage $ PackageName "Cabal"+ mapM_ transplantOptionalPackage ["haskell98", "haskell2010", "ghc", "ghc-binary"]+ Tarball _ ->+ debug "Using external GHC - nothing to copy, Virtual environment will reuse GHC package database"++installGhc :: MyMonad ()+installGhc = do+ info "Installing GHC"+ ghc <- asks ghcSource+ case ghc of+ System -> indentMessages $ debug "Using system version of GHC - nothing to install."+ Tarball tarballPath -> indentMessages $ installExternalGhc tarballPath++installExternalGhc :: FilePath -> MyMonad ()+installExternalGhc tarballPath = do+ info $ "Installing GHC from " ++ tarballPath+ indentMessages $ do+ dirStructure <- vheDirStructure+ tmpGhcDir <- liftIO $ createTemporaryDirectory (virthualEnv dirStructure) "ghc"+ debug $ "Unpacking GHC tarball to " ++ tmpGhcDir+ _ <- indentMessages $ runProcess Nothing "tar" ["xf", tarballPath, "-C", tmpGhcDir, "--strip-components", "1"] Nothing+ let configureScript = tmpGhcDir </> "configure"+ debug $ "Configuring GHC with prefix " ++ ghcDir dirStructure+ cwd <- liftIO getCurrentDirectory+ liftIO $ setCurrentDirectory tmpGhcDir+ make <- asks makeCmd+ let configureAndInstall = do+ _ <- indentMessages $ runProcess Nothing configureScript ["--prefix=" ++ ghcDir dirStructure] Nothing+ debug $ "Installing GHC with " ++ make ++ " install"+ _ <- indentMessages $ runProcess Nothing make ["install"] Nothing+ return ()+ configureAndInstall `finally` liftIO (setCurrentDirectory cwd)+ liftIO $ removeDirectoryRecursive tmpGhcDir+ return ()
+ src/Args.hs view
@@ -0,0 +1,153 @@+{-# 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
+ src/MyMonad.hs view
@@ -0,0 +1,87 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+module MyMonad ( MyMonad+ , runMyMonad+ , indentMessages+ , debug+ , info+ , trace+ , warning+ , finally+ , throwError+ , catchError+ , asks+ , gets+ , tell+ , modify+ , liftIO+ ) where++import Types++import Control.Monad.Trans (MonadIO, liftIO)+import Control.Monad.Reader (ReaderT, MonadReader, runReaderT, asks)+import Control.Monad.Writer (WriterT, MonadWriter, runWriterT, tell)+import Control.Monad.State (StateT, MonadState, evalStateT, modify, gets)+import Control.Monad.Error (ErrorT, MonadError, runErrorT, throwError, catchError)+import Control.Monad (when)+import System.IO (stderr, hPutStrLn)++import Prelude hiding (log)++newtype MyMonad a = MyMonad (StateT MyState (ReaderT Options (ErrorT MyException (WriterT [String] IO))) a)+ deriving (Functor, Monad, MonadReader Options, MonadState MyState, MonadError MyException, MonadWriter [String])++instance MonadIO MyMonad where+ liftIO m = MyMonad $ do+ x <- liftIO $ (Right `fmap` m) `catch` (return . Left)+ case x of+ Left e -> throwError $ MyException $ "IO error: " ++ show e+ Right y -> return y++runMyMonad :: MyMonad a -> Options -> IO (Either MyException a, [String])+runMyMonad (MyMonad m) = runWriterT . runErrorT . runReaderT (evalStateT m (MyState 0))++finally :: MyMonad a -> MyMonad b -> MyMonad a+finally m sequel = do+ result <- (Right `fmap` m) `catchError` (return . Left)+ _ <- sequel+ case result of+ Left e -> throwError e+ Right x -> return x++indentMessages :: MyMonad a -> MyMonad a+indentMessages m = do+ modify (\s -> s{logDepth = logDepth s + 2})+ result <- m+ modify (\s -> s{logDepth = logDepth s - 2})+ return result++-- add message to private log and return adjusted message (with log depth)+-- that can be printed somewhere else+privateLog :: String -> MyMonad String+privateLog str = do+ depth <- gets logDepth+ let text = replicate (fromInteger depth) ' ' ++ str+ tell [text]+ return text++log :: Verbosity -> String -> MyMonad ()+log minLevel str = do+ text <- privateLog str+ flag <- asks verbosity+ when (flag >= minLevel) $+ liftIO $ putStrLn text++debug :: String -> MyMonad ()+debug = log Verbose++info :: String -> MyMonad ()+info = log Quiet++trace :: String -> MyMonad ()+trace = log VeryVerbose++warning :: String -> MyMonad ()+warning str = do+ text <- privateLog str+ liftIO $ hPutStrLn stderr text
+ src/PackageManagement.hs view
@@ -0,0 +1,103 @@+module PackageManagement ( Transplantable(..)+ , parseVersion+ , parsePkgInfo+ ) where++import Distribution.Package (PackageIdentifier(..), PackageName(..))+import Distribution.Version (Version(..))+import Control.Monad (unless)++import Types+import MyMonad+import Process (outsideGhcPkg, insideGhcPkg)+import Util.Cabal (prettyPkgInfo, prettyVersion)+import qualified Util.Cabal (parseVersion, parsePkgInfo)++parseVersion :: String -> MyMonad Version+parseVersion s = case Util.Cabal.parseVersion s of+ Nothing -> throwError $ MyException $ "Couldn't parse " ++ s ++ " as a package version"+ Just version -> return version++parsePkgInfo :: String -> MyMonad PackageIdentifier+parsePkgInfo s = case Util.Cabal.parsePkgInfo s of+ Nothing -> throwError $ MyException $ "Couldn't parse package identifier " ++ s+ Just pkgInfo -> return pkgInfo++getDeps :: PackageIdentifier -> MyMonad [PackageIdentifier]+getDeps pkgInfo = do+ let prettyPkg = prettyPkgInfo pkgInfo+ debug $ "Extracting dependencies of " ++ prettyPkg+ out <- indentMessages $ outsideGhcPkg ["field", prettyPkg, "depends"]+ -- example output:+ -- depends: ghc-prim-0.2.0.0-3fbcc20c802efcd7c82089ec77d92990+ -- integer-gmp-0.2.0.0-fa82a0df93dc30b4a7c5654dd7c68cf4 builtin_rts+ case words out of+ [] -> throwError $ MyException $ "Couldn't parse ghc-pkg output to find dependencies of " ++ prettyPkg+ _:depStrings -> do -- skip 'depends:'+ indentMessages $ trace $ "Found dependency strings: " ++ unwords depStrings+ mapM parsePkgInfo depStrings++-- things that can be copied from system's GHC pkg database+-- to GHC pkg database inside virtual environment+class Transplantable a where+ transplantPackage :: a -> MyMonad ()++-- choose the highest installed version of package with this name+instance Transplantable PackageName where+ transplantPackage (PackageName packageName) = do+ debug $ "Copying package " ++ packageName ++ " to Virtual Haskell Environment."+ indentMessages $ do+ debug "Choosing package with highest version number."+ out <- indentMessages $ outsideGhcPkg ["field", packageName, "version"]+ -- example output:+ -- version: 1.1.4+ -- version: 1.2.0.3+ let extractVersionString :: String -> MyMonad String+ extractVersionString line = case words line of+ [_, x] -> return x+ _ -> throwError $ MyException $ "Couldn't extract version string from: " ++ line+ versionStrings <- mapM extractVersionString $ lines out+ indentMessages $ trace $ "Found version strings: " ++ unwords versionStrings+ versions <- mapM parseVersion versionStrings+ case versions of+ [] -> throwError $ MyException $ "No versions of package " ++ packageName ++ " found"+ (v:vs) -> do+ indentMessages $ debug $ "Found: " ++ unwords (map prettyVersion versions)+ let highestVersion = foldr max v vs+ indentMessages $ debug $ "Using version: " ++ prettyVersion highestVersion+ let pkgInfo = PackageIdentifier (PackageName packageName) highestVersion+ transplantPackage pkgInfo++-- check if this package is already installed in Virtual Haskell Environment+checkIfInstalled :: PackageIdentifier -> MyMonad Bool+checkIfInstalled pkgInfo = do+ let package = prettyPkgInfo pkgInfo+ debug $ "Checking if " ++ package ++ " is already installed."+ (do+ _ <- indentMessages $ insideGhcPkg ["describe", package] Nothing+ indentMessages $ debug "It is."+ return True) `catchError` handler+ where handler _ = do+ debug "It's not."+ return False++instance Transplantable PackageIdentifier where+ transplantPackage pkgInfo = do+ let prettyPkg = prettyPkgInfo pkgInfo+ debug $ "Copying package " ++ prettyPkg ++ " to Virtual Haskell Environment."+ indentMessages $ do+ flag <- checkIfInstalled pkgInfo+ unless flag $ do+ deps <- getDeps pkgInfo+ debug $ "Found: " ++ unwords (map prettyPkgInfo deps)+ mapM_ transplantPackage deps+ movePackage pkgInfo++-- copy single package that already has all deps satisfied+movePackage :: PackageIdentifier -> MyMonad ()+movePackage pkgInfo = do+ let prettyPkg = prettyPkgInfo pkgInfo+ debug $ "Moving package " ++ prettyPkg ++ " to Virtual Haskell Environment."+ out <- outsideGhcPkg ["describe", prettyPkg]+ _ <- insideGhcPkg ["register", "-"] (Just out)+ return ()
+ src/Paths.hs view
@@ -0,0 +1,45 @@+module Paths ( vheDirStructure+ , cabalConfigLocation+ , getVirtualEnvironment+ ) where++import System.FilePath ((</>))+import System.Directory (getCurrentDirectory)+import System.Environment (getEnvironment)++import Types+import MyMonad++-- returns record containing paths to all important directories+-- inside virtual environment dir structure+vheDirStructure :: MyMonad DirStructure+vheDirStructure = do+ cwd <- liftIO getCurrentDirectory+ let virthualEnvLocation = cwd+ virthualEnvDirLocation = virthualEnvLocation </> ".virthualenv"+ cabalDirLocation = virthualEnvDirLocation </> "cabal"+ ghcDirLocation = virthualEnvDirLocation </> "ghc"+ return DirStructure { virthualEnv = virthualEnvLocation+ , virthualEnvDir = virthualEnvDirLocation+ , ghcPackagePath = virthualEnvDirLocation </> "ghc_pkg_db"+ , cabalDir = cabalDirLocation+ , cabalBinDir = cabalDirLocation </> "bin"+ , virthualEnvBinDir = virthualEnvDirLocation </> "bin"+ , ghcDir = ghcDirLocation+ , ghcBinDir = ghcDirLocation </> "bin"+ }++-- returns location of cabal's config file inside virtual environment dir structure+cabalConfigLocation :: MyMonad FilePath+cabalConfigLocation = do+ dirStructure <- vheDirStructure+ return $ cabalDir dirStructure </> "config"++-- returns environment dictionary used in Virtual Haskell Environment+-- it's inherited from the current process, but variable+-- GHC_PACKAGE_PATH is altered.+getVirtualEnvironment :: MyMonad [(String, String)]+getVirtualEnvironment = do+ env <- liftIO getEnvironment+ dirStructure <- vheDirStructure+ return $ ("GHC_PACKAGE_PATH", ghcPackagePath dirStructure) : filter (\(k,_) -> k /= "GHC_PACKAGE_PATH") env
+ src/Process.hs view
@@ -0,0 +1,108 @@+module Process ( externalGhcPkgDb+ , outsideGhcPkg+ , insideGhcPkg+ , runProcess+ , ghcPkgDbPathLocation+ ) where++import Types+import MyMonad+import Paths++import Util.IO (readProcessWithExitCodeInEnv, Environment)++import Control.Monad (forM_)+import Data.Maybe (fromMaybe)+import System.FilePath ((</>))+import System.Process (readProcessWithExitCode)+import System.Exit (ExitCode(..))++runProcess :: Maybe Environment -> FilePath -> [String] -> Maybe String -> MyMonad String+runProcess env prog args input = do+ debug $ unwords $ ["Executing:", prog] ++ args+ indentMessages $ case env of+ Nothing -> trace "using inherited variable environment"+ Just env' -> do+ trace "using following environment:"+ indentMessages $ forM_ env' $ \(var,val) -> trace $ var ++ ": " ++ val+ indentMessages $ case input of+ Nothing -> return ()+ Just inp -> do+ trace "using the following input:"+ indentMessages $ forM_ (lines inp) trace+ let execProcess = case env of+ Nothing -> readProcessWithExitCode prog args (fromMaybe "" input)+ Just env' -> readProcessWithExitCodeInEnv env' prog args input+ (exitCode, output, errors) <- liftIO execProcess+ indentMessages $ debug $ case exitCode of+ ExitSuccess -> "Process exited successfully"+ ExitFailure errCode -> "Process failed with exit code " ++ show errCode+ indentMessages $ do+ trace "Process output:"+ indentMessages $ forM_ (lines output) trace+ indentMessages $ do+ trace "Process error output:"+ indentMessages $ forM_ (lines errors) trace+ case exitCode of+ ExitSuccess -> return output+ ExitFailure errCode -> throwError $ MyException $ prog ++ " process failed with status " ++ show errCode++-- run outside ghc-pkg tool (uses system's or from ghc installed from tarball)+outsideGhcPkg :: [String] -> MyMonad String+outsideGhcPkg args = do+ ghc <- asks ghcSource+ dirStructure <- vheDirStructure+ ghcPkg <- case ghc of+ System -> do+ debug "Running system's version of ghc-pkg"+ return "ghc-pkg"+ Tarball _ -> do+ debug "Running ghc-pkg installed from GHC's tarball"+ return $ ghcDir dirStructure </> "bin" </> "ghc-pkg"+ indentMessages $ runProcess Nothing ghcPkg args Nothing++-- returns path to GHC (installed from tarball) builtin package database+externalGhcPkgDb :: MyMonad FilePath+externalGhcPkgDb = do+ debug "Checking where GHC (installed from tarball) keeps its package database"+ out <- indentMessages $ outsideGhcPkg ["list"]+ indentMessages $ debug "Trying to parse ghc-pkg's output"+ case lines out of+ [] -> throwError $ MyException "ghc-pkg returned empty output"+ lineWithPath:_ ->+ case lineWithPath of+ "" -> throwError $ MyException "ghc-pkg's first line of output is empty"+ _ -> do+ -- ghc-pkg ends pkg db path with trailing colon+ -- but only when not run from the terminal+ let path = init lineWithPath+ indentMessages $ debug $ "Found: " ++ path+ return path++-- run ghc-pkg tool (uses system's or from ghc installed from tarball)+-- from the inside of Virtual Haskell Environment+insideGhcPkg :: [String] -> Maybe String -> MyMonad String+insideGhcPkg args input = do+ ghc <- asks ghcSource+ dirStructure <- vheDirStructure+ env <- getVirtualEnvironment+ ghcPkg <- case ghc of+ System -> do+ debug "Running system's version of ghc-pkg inside virtual environment"+ return "ghc-pkg"+ Tarball _ -> do+ debug "Running ghc-pkg, installed from GHC's tarball, inside virtual environment"+ return $ ghcDir dirStructure </> "bin" </> "ghc-pkg"+ indentMessages $ runProcess (Just env) ghcPkg args input++-- returns value of GHC_PACKAGE_PATH that should be used inside virtual environment+ghcPkgDbPathLocation :: MyMonad String+ghcPkgDbPathLocation = do+ debug "Determining value of GHC_PACKAGE_PATH to be used inside virtual environment"+ dirStructure <- vheDirStructure+ ghc <- asks ghcSource+ case ghc of+ System -> return $ ghcPackagePath dirStructure+ Tarball _ -> do+ externalGhcPkgDbPath <- indentMessages externalGhcPkgDb+ return $ ghcPackagePath dirStructure ++ ":" ++ externalGhcPkgDbPath
+ src/SanityCheck.hs view
@@ -0,0 +1,63 @@+module SanityCheck (sanityCheck) where++import Control.Monad (when)+import System.Directory (doesDirectoryExist)++import Util.IO (getEnvVar, which)+import Types+import MyMonad+import Paths (vheDirStructure)++-- check if any virtual env is already active+checkVHE :: MyMonad ()+checkVHE = do+ virthualEnvVar <- liftIO $ getEnvVar "VIRTHUALENV"+ case virthualEnvVar of+ Nothing -> return ()+ Just path -> do+ virthualEnvName <- liftIO $ getEnvVar "VIRTHUALENV_NAME"+ case virthualEnvName of+ Nothing -> do+ debug $ "warning: VIRTHUALENV environment variable is defined" ++ ", but no VIRHTUALENV_NAME environment variable defined."+ throwError $ MyException $ "There is already active Virtual Haskell Environment (at " ++ path ++ ")."+ Just name ->+ throwError $ MyException $ "There is already active " ++ name ++ " Virtual Haskell Environment (at " ++ path ++ ")."++checkVirthualEnvAlreadyExists :: MyMonad ()+checkVirthualEnvAlreadyExists = do+ dirStructure <- vheDirStructure+ flag <- liftIO $ doesDirectoryExist $ virthualEnvDir dirStructure+ when flag $ throwError $ MyException $ "There is already .virthualenv directory at " ++ virthualEnv dirStructure++-- check if cabal binary exist on PATH+checkCabalInstall :: MyMonad ()+checkCabalInstall = do+ cabalInstallPath <- liftIO $ which "cabal"+ case cabalInstallPath of+ Just _ -> return ()+ Nothing -> throwError $ MyException "Couldn't find cabal binary (from cabal-install package) in your $PATH."++-- check if GHC tools (ghc, ghc-pkg) exist on PATH+-- skip the check if using GHC from a tarball+checkGhc :: MyMonad ()+checkGhc = do+ ghcSrc <- asks ghcSource+ case ghcSrc of+ Tarball _ -> return ()+ System -> do+ ghcPath <- liftIO $ which "ghc"+ case ghcPath of+ Just _ -> return ()+ Nothing -> throwError $ MyException "Couldn't find ghc binary in your $PATH."+ ghc_pkgPath <- liftIO $ which "ghc-pkg"+ case ghc_pkgPath of+ Just _ -> return ()+ Nothing -> throwError $ MyException "Couldn't find ghc-pkg binary in your $PATH."++-- check if everything is sane+sanityCheck :: MyMonad ()+sanityCheck = do+ checkVHE+ checkVirthualEnvAlreadyExists+ checkCabalInstall+ checkGhc
+ src/Skeletons.hs view
@@ -0,0 +1,16 @@+{-# LANGUAGE TemplateHaskell #-}++module Skeletons where++import Data.FileEmbed (embedFile)+import Data.ByteString.Char8 (unpack)+import System.FilePath ((</>))++activateSkel :: String+activateSkel = unpack $(embedFile $ "skeletons" </> "activate")++cabalWrapperSkel :: String+cabalWrapperSkel = unpack $(embedFile $ "skeletons" </> "cabal")++cabalConfigSkel :: String+cabalConfigSkel = unpack $(embedFile $ "skeletons" </> "cabal_config")
+ src/Types.hs view
@@ -0,0 +1,42 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+module Types ( GhcSource(..)+ , Options(..)+ , MyState(..)+ , DirStructure(..)+ , MyException(..)+ , Verbosity(..)+ ) where++import Control.Monad.Error (Error)++data GhcSource = System -- Use System's copy of GHC+ | Tarball FilePath -- Use GHC from tarball++data Verbosity = Quiet+ | Verbose+ | VeryVerbose+ deriving (Eq, Ord)++data Options = Options { verbosity :: Verbosity+ , skipSanityCheck :: Bool+ , vheName :: String -- Virtual Haskell Environment name+ , ghcSource :: GhcSource+ , makeCmd :: String -- make substitute used for 'make install' of external GHC+ }++data MyState = MyState { logDepth :: Integer -- used for indentation of logging messages+ }++newtype MyException = MyException { getExceptionMessage :: String }+ deriving Error++-- Only absolute paths!+data DirStructure = DirStructure { virthualEnv :: FilePath -- dir containing .virthualenv dir (usually dir with cabal project)+ , virthualEnvDir :: FilePath -- .virthualenv dir+ , ghcPackagePath :: FilePath -- file (<ghc-6.12) or dir (>=ghc-6.12) containing private GHC pkg db+ , cabalDir :: FilePath -- directory with private cabal dir+ , cabalBinDir :: FilePath -- cabal's bin/ dir (used in $PATH)+ , virthualEnvBinDir :: FilePath -- dir with haskell tools wrappers and activate script+ , ghcDir :: FilePath -- directory with private copy of external GHC (only used when using GHC from tarball)+ , ghcBinDir :: FilePath -- ghc's bin/ dir (with ghc[i|-pkg]) (only used when using GHC from tarball)+ }
+ src/Util/Cabal.hs view
@@ -0,0 +1,39 @@+module Util.Cabal ( prettyVersion+ , prettyPkgInfo+ , parseVersion+ , parsePkgInfo+ ) where++import Distribution.Version (Version(..))+import Distribution.Package (PackageIdentifier(..), PackageName(..))+import Distribution.Compat.ReadP (readP_to_S)+import Distribution.Text (parse, Text)++import Data.Char (isSpace)+import Data.List (isPrefixOf, intercalate)++-- render Version to human and ghc-pkg readable string+prettyVersion :: Version -> String+prettyVersion (Version [] _) = ""+prettyVersion (Version numbers _) = intercalate "." $ map show numbers++-- render PackageIdentifier to human and ghc-pkg readable string+prettyPkgInfo :: PackageIdentifier -> String+prettyPkgInfo (PackageIdentifier (PackageName name) (Version [] _)) = name+prettyPkgInfo (PackageIdentifier (PackageName name) version) =+ name ++ "-" ++ prettyVersion version++parseVersion :: String -> Maybe Version+parseVersion = parseCheck++parseCheck :: Text a => String -> Maybe a+parseCheck str =+ case [ x | (x,ys) <- readP_to_S parse str, all isSpace ys ] of+ [x] -> Just x+ _ -> Nothing++parsePkgInfo :: String -> Maybe PackageIdentifier+parsePkgInfo str | "builtin_" `isPrefixOf` str =+ let name = drop (length "builtin_") str -- ghc-pkg doesn't like builtin_ prefix+ in Just $ PackageIdentifier (PackageName name) $ Version [] []+ | otherwise = parseCheck str
+ src/Util/IO.hs view
@@ -0,0 +1,81 @@+module Util.IO ( getEnvVar+ , makeExecutable+ , readProcessWithExitCodeInEnv+ , Environment+ , createTemporaryDirectory+ , which+ ) where++import System.Environment (getEnv)+import System.IO.Error (isDoesNotExistError)+import System.Directory (getPermissions, setPermissions, executable, removeFile, createDirectory, doesFileExist)+import Control.Concurrent (forkIO, putMVar, takeMVar, newEmptyMVar)+import Control.Exception (evaluate)+import System.Process (runInteractiveProcess, waitForProcess)+import System.IO (hGetContents, hPutStr, hFlush, hClose, openTempFile)+import System.Exit (ExitCode)+import Data.List.Split (splitOn)+import Control.Monad (foldM)+import System.FilePath ((</>))++-- Computation getEnvVar var returns Just the value of the environment variable var,+-- or Nothing if the environment variable does not exist+getEnvVar :: String -> IO (Maybe String)+getEnvVar var = Just `fmap` getEnv var `catch` noValueHandler+ where noValueHandler e | isDoesNotExistError e = return Nothing+ | otherwise = ioError e++makeExecutable :: FilePath -> IO ()+makeExecutable path = do+ perms <- getPermissions path+ setPermissions path perms{executable = True}++type Environment = [(String, String)]++-- like readProcessWithExitCode, but takes additional environment argument+readProcessWithExitCodeInEnv :: Environment -> FilePath -> [String] -> Maybe String -> IO (ExitCode, String, String)+readProcessWithExitCodeInEnv env progName args input = do+ (inh, outh, errh, pid) <- runInteractiveProcess progName args Nothing (Just env)+ out <- hGetContents outh+ outMVar <- newEmptyMVar+ _ <- forkIO $ evaluate (length out) >> putMVar outMVar ()+ err <- hGetContents errh+ errMVar <- newEmptyMVar+ _ <- forkIO $ evaluate (length err) >> putMVar errMVar ()+ case input of+ Just inp | not (null inp) -> hPutStr inh inp >> hFlush inh+ _ -> return ()+ hClose inh+ takeMVar outMVar+ hClose outh+ takeMVar errMVar+ hClose errh+ ex <- waitForProcess pid+ return (ex, out, err)++-- similar to openTempFile, but creates a temporary directory+-- and returns its path+createTemporaryDirectory :: FilePath -> String -> IO FilePath+createTemporaryDirectory parentDir templateName = do+ (path, handle) <- openTempFile parentDir templateName+ hClose handle+ removeFile path+ createDirectory path+ return path++which :: String -> IO (Maybe FilePath)+which name = do+ path <- getEnvVar "PATH"+ case path of+ Nothing -> return Nothing+ Just path' -> do+ let pathElems = splitOn ":" path'+ aux x@(Just _) _ = return x+ aux Nothing pathDir = do+ let programPath = pathDir </> name+ flag <- doesFileExist programPath+ if flag then+ return $ Just programPath+ else+ return Nothing+ foldM aux Nothing pathElems
+ src/Util/Template.hs view
@@ -0,0 +1,22 @@+module Util.Template ( substs+ ) where++import Data.List (isPrefixOf)++-- Simple templating system+-- most of the existing tools are either too complicated+-- or use $ (or even ${}) chars for variables, which is unfortunate+-- for use with [ba]sh templates.++type Substitution = (String, String)++-- substitute all occurences of FROM to TO+subst :: Substitution -> String -> String+subst _ [] = []+subst phi@(from, to) input@(x:xs)+ | from `isPrefixOf` input = to ++ subst phi (drop (length from) input)+ | otherwise = x:subst phi xs++-- multi version of subst+substs :: [Substitution] -> String -> String+substs phis str = foldr subst str phis
+ src/virthualenv.hs view
@@ -0,0 +1,55 @@+import System.Environment (getArgs)+import System.IO (stderr, hPutStrLn)+import System.Exit (exitFailure)+import System.FilePath ((</>))++import Types+import MyMonad+import Actions+import SanityCheck (sanityCheck)+import Args (usage, parseArgs)++main :: IO ()+main = do+ args <- getArgs+ case args of+ ["--version"] -> putStrLn "0.2"+ ["--help"] -> usage+ ["-h"] -> usage+ _ ->+ do+ opts <- parseArgs args+ case opts of+ Left err -> do+ hPutStrLn stderr err+ usage+ exitFailure+ Right options -> do+ (result, messageLog) <- runMyMonad realMain options+ case result of+ Left err -> do+ hPutStrLn stderr $ getExceptionMessage err+ hPutStrLn stderr ""+ hPutStrLn stderr "virthualenv.log file contains detailed description of the process."+ let errorLog = unlines $ messageLog ++ ["", getExceptionMessage err]+ writeFile "virthualenv.log" errorLog+ exitFailure+ Right () -> writeFile (".virthualenv" </> "virthualenv.log") $ unlines messageLog++realMain :: MyMonad ()+realMain = do+ skipSanityCheckFlag <- asks skipSanityCheck+ if skipSanityCheckFlag then+ info "WARNING: sanity checks are disabled."+ else+ sanityCheck+ createDirStructure+ installGhc+ initGhcDb+ copyBaseSystem+ installCabalConfig+ installActivateScript+ installCabalWrapper+ cabalUpdate+ info ""+ info "To activate the new environment use 'source .virthualenv/bin/activate'"
+ virthualenv.cabal view
@@ -0,0 +1,127 @@+Name: virthualenv++Version: 0.2++Synopsis: Virtual Haskell Environment builder++Description: virthualenv is a tool (inspired by Python's virtualenv) to create isolated Haskell environments.+ .+ It creates a sandboxed environment in a .virthualenv/ directory, which, when activated,+ allows you to use regular Haskell tools (ghc, ghci, ghc-pkg, cabal) to manage your Haskell+ code and environment. It's possible to create an environment, that uses different GHC version+ than your currently installed. virthualenv is supposed to be easier to learn (and use) than+ similar packages (like cabal-dev or capri).+ .+ Basic usage.+ .+ First, choose a directory where you want to keep your sandboxed Haskell environment,+ usually a good choice is a directory containing your cabalized project (if you want to work+ on a few projects (perhaps an app and its dependent library), just choose any of them,+ it doesn't really matter). Enter that directory:+ .+ > cd ~/projects/foo+ .+ Next, create your new isolated Haskell environment (this is a one time only (per environment) step):+ .+ > virthualenv+ .+ Now, every time you want to use this enviroment, you have to activate it:+ .+ > source .virthualenv/bin/activate+ .+ That's it! Now it's possible to use all regular Haskell tools like usual, but it won't affect+ your global/system's Haskell environment, and also your per-user environment (from ~/.cabal and+ ~/.ghc) will stay the same. All cabal-installed packages will be private to this environment,+ and also the external environments (global and user) will not affect it (this environment+ will only inherit very basic packages - mostly ghc and Cabal and their deps).+ .+ When you're done working with this environment, enter command 'deactivate',+ or just close the current shell (with exit).+ .+ > deactivate+ .+ Advanced usage.+ .+ The only advanced usage is using different GHC version. This can be useful to test your code+ against different GHC version (even against nightly builds).+ .+ First, download binary distribution of GHC for your platform+ (e.g. ghc-7.0.4-i386-unknown-linux.tar.bz2), then create a new environment using that GHC+ .+ > virthualenv --ghc=/path/to/ghc_something.tar.bz2+ .+ Then, proceed (with [de]activation) as in basic case.+ .+ Misc.+ .+ virthualenv has been tested on i386 Linux systems, but it should work on any Posix platform.+ External (from tarball) GHC feature requires binary GHC distribution compiled for your platform,+ that can be extracted with tar and installed with "./configure --prefix=PATH; make install".+ .+ For more info please consult "virthualenv --help" or the attached README file.++Homepage: https://github.com/Paczesiowa/virthualenv++License: BSD3++License-file: LICENSE++Author: Bartosz Ćwikłowski++Maintainer: paczesiowa@gmail.com++Copyright: (c) 2011 Bartosz Ćwikłowski++Category: Development++Build-type: Simple++Stability: alpha++Bug-reports: https://github.com/Paczesiowa/virthualenv/issues++Package-url: http://hackage.haskell.org/package/virthualenv++Tested-with: GHC == 6.12.3, GHC == 7.0.4++Data-files: virthualenv.el, README.md++Extra-source-files: skeletons/activate, skeletons/cabal, skeletons/cabal_config++Cabal-version: >=1.6++Executable virthualenv++ Main-is: virthualenv.hs++ Hs-source-dirs: src++ Ghc-options: -threaded -Wall++ Build-depends: base >= 4.2.0.0 && < 4.5+ , process >= 1.0.1.2 && < 1.2+ , filepath >= 1.1.0.3 && < 1.3+ , directory >= 1.0.1.0 && < 1.2+ , Cabal >= 1.8.0.6 && < 1.13+ , mtl >= 1.1.0.2 && < 2.1+ , bytestring >= 0.9.1.7 && < 0.10+ , file-embed >= 0.0.4.1 && < 0.1+ , split >= 0.1.4 && < 0.2+ , safe >= 0.3 && < 0.4++ Other-modules: Util.Cabal+ , Util.Template+ , Util.IO+ , Skeletons+ , Types+ , MyMonad+ , Args+ , Paths+ , SanityCheck+ , Process+ , PackageManagement+ , Actions++Source-repository head+ Type: git+ Location: git://github.com/Paczesiowa/virthualenv.git
+ virthualenv.el view
@@ -0,0 +1,42 @@+(setq virthualenv nil)+(setq virthualenv-path-backup nil)+(setq virthualenv-exec-path-backup nil)++(defun virthualenv-read-file (fpath)+ (with-temp-buffer+ (insert-file-contents fpath)+ (buffer-string)))++(defun virthualenv-activate (dir)+ "Activate the Virtual Haskell Environment in DIR"+ (interactive "Dvirthualenv directory: ")+ (when (equal (char-list-to-string (last (string-to-list dir)))+ "/")+ (setq dir (subseq dir+ 0+ (- (length dir) 1))))+ (let* ((virthualenv-dir (concat dir "/.virthualenv/"))+ (path-var-prependix-location (concat virthualenv-dir "path_var_prependix"))+ (ghc-package-path-var-location (concat virthualenv-dir "ghc_package_path_var"))+ (path-var-prependix (virthualenv-read-file path-var-prependix-location))+ (ghc-package-path-var (virthualenv-read-file ghc-package-path-var-location))+ (new-path-var (concat path-var-prependix ":" (getenv "PATH")))+ (exec-path-prependix (split-string path-var-prependix ":")))+ (setq virthualenv-path-backup (getenv "PATH"))+ (setenv "PATH" new-path-var)+ (setq virthualenv-exec-path-backup exec-path)+ (setq exec-path (append exec-path-prependix exec-path))+ (setenv "GHC_PACKAGE_PATH" ghc-package-path-var)+ (setq virthualenv dir)))++(defun virthualenv-deactivate ()+ "Deactivate the Virtual Haskell Environment"+ (interactive)+ (setenv "PATH" virthualenv-path-backup)+ (setq exec-path virthualenv-exec-path-backup)+ (setenv "GHC_PACKAGE_PATH" nil)+ (setq virthualenv nil)+ (setq virthualenv-path-backup nil)+ (setq virthualenv-exec-path-backup nil))++(provide 'virthualenv)