├── .hgignore ├── src ├── .ghci ├── Skeletons.hs ├── Util │ ├── Template.hs │ ├── Cabal.hs │ ├── Tar.hs │ └── IO.hs ├── virthualenv.hs ├── Paths.hs ├── Types.hs ├── SanityCheck.hs ├── MyMonad.hs ├── Process.hs ├── PackageManagement.hs ├── Args.hs └── Actions.hs ├── .hgtags ├── Setup.hs ├── skeletons ├── cabal_config ├── cabal └── activate ├── LICENSE ├── virthualenv.el ├── README.md └── virthualenv.cabal /.hgignore: -------------------------------------------------------------------------------- 1 | ^dist/.* 2 | -------------------------------------------------------------------------------- /src/.ghci: -------------------------------------------------------------------------------- 1 | :set -isrc/ 2 | -------------------------------------------------------------------------------- /.hgtags: -------------------------------------------------------------------------------- 1 | 287bc1330e0d38b3f10b6d5a0c68eff70ab756e7 0.2 2 | -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /skeletons/cabal_config: -------------------------------------------------------------------------------- 1 | remote-repo: hackage.haskell.org:http://hackage.haskell.org/packages/archive 2 | remote-repo-cache: /packages 3 | logs-dir: /logs 4 | world-file: /world 5 | package-db: 6 | build-summary: /logs/build.log 7 | remote-build-reporting: anonymous 8 | install-dirs user 9 | prefix: 10 | -------------------------------------------------------------------------------- /src/Skeletons.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell #-} 2 | 3 | module Skeletons where 4 | 5 | import Data.FileEmbed (embedFile) 6 | import Data.ByteString.Char8 (unpack) 7 | import System.FilePath (()) 8 | 9 | activateSkel :: String 10 | activateSkel = unpack $(embedFile $ "skeletons" "activate") 11 | 12 | cabalWrapperSkel :: String 13 | cabalWrapperSkel = unpack $(embedFile $ "skeletons" "cabal") 14 | 15 | cabalConfigSkel :: String 16 | cabalConfigSkel = unpack $(embedFile $ "skeletons" "cabal_config") 17 | -------------------------------------------------------------------------------- /skeletons/cabal: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | 3 | PATH_ELEMS="$(echo ${PATH} | tr -s ':' '\n')" 4 | 5 | ORIG_CABAL_BINARY="" 6 | 7 | for PATH_ELEM in ${PATH_ELEMS}; do 8 | CABAL_CANDIDATE="${PATH_ELEM}/cabal" 9 | if command -v "${CABAL_CANDIDATE}" > /dev/null 2> /dev/null; then 10 | if [ "${0}" != "${CABAL_CANDIDATE}" ]; then 11 | if [ -z "${ORIG_CABAL_BINARY}" ]; then 12 | ORIG_CABAL_BINARY="${CABAL_CANDIDATE}" 13 | fi 14 | fi 15 | fi 16 | done 17 | 18 | if [ -z "${ORIG_CABAL_BINARY}" ]; then 19 | echo "cabal wrapper: Couldn't find real cabal program" 20 | exit 1 21 | fi 22 | 23 | CABAL_CONFIG="" 24 | 25 | exec "${ORIG_CABAL_BINARY}" --config-file="${CABAL_CONFIG}" "${@}" 26 | -------------------------------------------------------------------------------- /src/Util/Template.hs: -------------------------------------------------------------------------------- 1 | module Util.Template ( substs 2 | ) where 3 | 4 | import Data.List (isPrefixOf) 5 | 6 | -- Simple templating system 7 | -- most of the existing tools are either too complicated 8 | -- or use $ (or even ${}) chars for variables, which is unfortunate 9 | -- for use with [ba]sh templates. 10 | 11 | type Substitution = (String, String) 12 | 13 | -- substitute all occurences of FROM to TO 14 | subst :: Substitution -> String -> String 15 | subst _ [] = [] 16 | subst phi@(from, to) input@(x:xs) 17 | | from `isPrefixOf` input = to ++ subst phi (drop (length from) input) 18 | | otherwise = x:subst phi xs 19 | 20 | -- multi version of subst 21 | substs :: [Substitution] -> String -> String 22 | substs phis str = foldr subst str phis 23 | -------------------------------------------------------------------------------- /src/Util/Cabal.hs: -------------------------------------------------------------------------------- 1 | module Util.Cabal ( prettyVersion 2 | , prettyPkgInfo 3 | , parseVersion 4 | , parsePkgInfo 5 | ) where 6 | 7 | import Distribution.Version (Version(..)) 8 | import Distribution.Package (PackageIdentifier(..), PackageName(..)) 9 | import Distribution.Compat.ReadP (readP_to_S) 10 | import Distribution.Text (parse, Text) 11 | 12 | import Data.Char (isSpace) 13 | import Data.List (isPrefixOf, intercalate) 14 | 15 | -- render Version to human and ghc-pkg readable string 16 | prettyVersion :: Version -> String 17 | prettyVersion (Version [] _) = "" 18 | prettyVersion (Version numbers _) = intercalate "." $ map show numbers 19 | 20 | -- render PackageIdentifier to human and ghc-pkg readable string 21 | prettyPkgInfo :: PackageIdentifier -> String 22 | prettyPkgInfo (PackageIdentifier (PackageName name) (Version [] _)) = name 23 | prettyPkgInfo (PackageIdentifier (PackageName name) version) = 24 | name ++ "-" ++ prettyVersion version 25 | 26 | parseVersion :: String -> Maybe Version 27 | parseVersion = parseCheck 28 | 29 | parseCheck :: Text a => String -> Maybe a 30 | parseCheck str = 31 | case [ x | (x,ys) <- readP_to_S parse str, all isSpace ys ] of 32 | [x] -> Just x 33 | _ -> Nothing 34 | 35 | parsePkgInfo :: String -> Maybe PackageIdentifier 36 | parsePkgInfo str | "builtin_" `isPrefixOf` str = 37 | let name = drop (length "builtin_") str -- ghc-pkg doesn't like builtin_ prefix 38 | in Just $ PackageIdentifier (PackageName name) $ Version [] [] 39 | | otherwise = parseCheck str 40 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c)2011, Bartosz Ćwikłowski 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are met: 7 | 8 | * Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 11 | * Redistributions in binary form must reproduce the above 12 | copyright notice, this list of conditions and the following 13 | disclaimer in the documentation and/or other materials provided 14 | with the distribution. 15 | 16 | * Neither the name of Bartosz Ćwikłowski nor the names of other 17 | contributors may be used to endorse or promote products derived 18 | from this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 31 | -------------------------------------------------------------------------------- /virthualenv.el: -------------------------------------------------------------------------------- 1 | (setq virthualenv nil) 2 | (setq virthualenv-path-backup nil) 3 | (setq virthualenv-exec-path-backup nil) 4 | 5 | (defun virthualenv-read-file (fpath) 6 | (with-temp-buffer 7 | (insert-file-contents fpath) 8 | (buffer-string))) 9 | 10 | (defun virthualenv-activate (dir) 11 | "Activate the Virtual Haskell Environment in DIR" 12 | (interactive "Dvirthualenv directory: ") 13 | (when (string-match "^.*/$" dir) 14 | (setq dir (substring dir 0 -1))) 15 | (let* ((virthualenv-dir (concat dir "/.virthualenv/")) 16 | (path-var-prependix-location (concat virthualenv-dir "path_var_prependix")) 17 | (ghc-package-path-var-location (concat virthualenv-dir "ghc_package_path_var")) 18 | (path-var-prependix (virthualenv-read-file path-var-prependix-location)) 19 | (ghc-package-path-var (virthualenv-read-file ghc-package-path-var-location)) 20 | (new-path-var (concat path-var-prependix ":" (getenv "PATH"))) 21 | (exec-path-prependix (split-string path-var-prependix ":"))) 22 | (setq virthualenv-path-backup (getenv "PATH")) 23 | (setenv "PATH" new-path-var) 24 | (setq virthualenv-exec-path-backup exec-path) 25 | (setq exec-path (append exec-path-prependix exec-path)) 26 | (setenv "GHC_PACKAGE_PATH" ghc-package-path-var) 27 | (setq virthualenv dir))) 28 | 29 | (defun virthualenv-deactivate () 30 | "Deactivate the Virtual Haskell Environment" 31 | (interactive) 32 | (setenv "PATH" virthualenv-path-backup) 33 | (setq exec-path virthualenv-exec-path-backup) 34 | (setenv "GHC_PACKAGE_PATH" nil) 35 | (setq virthualenv nil) 36 | (setq virthualenv-path-backup nil) 37 | (setq virthualenv-exec-path-backup nil)) 38 | 39 | (provide 'virthualenv) 40 | -------------------------------------------------------------------------------- /skeletons/activate: -------------------------------------------------------------------------------- 1 | if [ -n "${VIRTHUALENV}" ]; then 2 | if [ "" = "${VIRTHUALENV}" ]; then 3 | echo "${VIRTHUALENV_NAME} Virtual Haskell Environment is already active." 4 | else 5 | echo "There is already ${VIRTHUALENV_NAME} Virtual Haskell Environment activated." 6 | echo "Deactivate it first (using command 'deactivate'), to activate" 7 | echo " environment." 8 | fi 9 | return 1 10 | fi 11 | 12 | export VIRTHUALENV="" 13 | export VIRTHUALENV_NAME="" 14 | 15 | echo "Activating ${VIRTHUALENV_NAME} Virtual Haskell Environment (at ${VIRTHUALENV})." 16 | echo "" 17 | echo "Use regular Haskell tools (ghc, ghci, ghc-pkg, cabal) to manage your Haskell environment." 18 | echo "" 19 | echo "To exit from this virtual environment, enter command 'deactivate'." 20 | 21 | export "VIRTHUALENV_PATH_BACKUP"="${PATH}" 22 | export "VIRTHUALENV_PS1_BACKUP"="${PS1}" 23 | 24 | deactivate() { 25 | echo "Deactivating ${VIRTHUALENV_NAME} Virtual Haskell Environment (at ${VIRTHUALENV})." 26 | echo "Restoring previous environment settings." 27 | 28 | export "PATH"="${VIRTHUALENV_PATH_BACKUP}" 29 | unset -v "VIRTHUALENV_PATH_BACKUP" 30 | export "PS1"="${VIRTHUALENV_PS1_BACKUP}" 31 | unset -v "VIRTHUALENV_PS1_BACKUP" 32 | 33 | unset -v VIRTHUALENV 34 | unset -v VIRTHUALENV_NAME 35 | unset -v GHC_PACKAGE_PATH 36 | unset -f deactivate 37 | 38 | if [ -n "$BASH" -o -n "$ZSH_VERSION" ]; then 39 | hash -r 40 | fi 41 | } 42 | 43 | PATH_PREPENDIX="$(cat /path_var_prependix)" 44 | export PATH="${PATH_PREPENDIX}:${PATH}" 45 | unset -v PATH_PREPENDIX 46 | 47 | export GHC_PACKAGE_PATH="$(cat /ghc_package_path_var)" 48 | export PS1="(${VIRTHUALENV_NAME})${PS1}" 49 | 50 | if [ -n "$BASH" -o -n "$ZSH_VERSION" ]; then 51 | hash -r 52 | fi 53 | -------------------------------------------------------------------------------- /src/virthualenv.hs: -------------------------------------------------------------------------------- 1 | import System.Environment (getArgs) 2 | import System.IO (stderr, hPutStrLn) 3 | import System.Exit (exitFailure) 4 | import System.FilePath (()) 5 | 6 | import Types 7 | import MyMonad 8 | import Actions 9 | import SanityCheck (sanityCheck) 10 | import Args (usage, parseArgs) 11 | 12 | main :: IO () 13 | main = do 14 | hPutStrLn stderr "virthualenv is deprecated, please use the hsenv tool." 15 | args <- getArgs 16 | case args of 17 | ["--version"] -> putStrLn "0.2.2" 18 | ["--help"] -> usage 19 | ["-h"] -> usage 20 | _ -> 21 | do 22 | opts <- parseArgs args 23 | case opts of 24 | Left err -> do 25 | hPutStrLn stderr err 26 | usage 27 | exitFailure 28 | Right options -> do 29 | (result, messageLog) <- runMyMonad realMain options 30 | case result of 31 | Left err -> do 32 | hPutStrLn stderr $ getExceptionMessage err 33 | hPutStrLn stderr "" 34 | hPutStrLn stderr "virthualenv.log file contains detailed description of the process." 35 | let errorLog = unlines $ messageLog ++ ["", getExceptionMessage err] 36 | writeFile "virthualenv.log" errorLog 37 | exitFailure 38 | Right () -> writeFile (".virthualenv" "virthualenv.log") $ unlines messageLog 39 | 40 | realMain :: MyMonad () 41 | realMain = do 42 | skipSanityCheckFlag <- asks skipSanityCheck 43 | if skipSanityCheckFlag then 44 | info "WARNING: sanity checks are disabled." 45 | else 46 | sanityCheck 47 | createDirStructure 48 | installGhc 49 | initGhcDb 50 | copyBaseSystem 51 | installCabalConfig 52 | installActivateScript 53 | installCabalWrapper 54 | cabalUpdate 55 | info "" 56 | info "To activate the new environment use 'source .virthualenv/bin/activate'" 57 | -------------------------------------------------------------------------------- /src/Paths.hs: -------------------------------------------------------------------------------- 1 | module Paths ( vheDirStructure 2 | , cabalConfigLocation 3 | , getVirtualEnvironment 4 | ) where 5 | 6 | import System.FilePath (()) 7 | import System.Directory (getCurrentDirectory) 8 | import System.Environment (getEnvironment) 9 | 10 | import Types 11 | import MyMonad 12 | 13 | -- returns record containing paths to all important directories 14 | -- inside virtual environment dir structure 15 | vheDirStructure :: MyMonad DirStructure 16 | vheDirStructure = do 17 | cwd <- liftIO getCurrentDirectory 18 | let virthualEnvLocation = cwd 19 | virthualEnvDirLocation = virthualEnvLocation ".virthualenv" 20 | cabalDirLocation = virthualEnvDirLocation "cabal" 21 | ghcDirLocation = virthualEnvDirLocation "ghc" 22 | return DirStructure { virthualEnv = virthualEnvLocation 23 | , virthualEnvDir = virthualEnvDirLocation 24 | , ghcPackagePath = virthualEnvDirLocation "ghc_pkg_db" 25 | , cabalDir = cabalDirLocation 26 | , cabalBinDir = cabalDirLocation "bin" 27 | , virthualEnvBinDir = virthualEnvDirLocation "bin" 28 | , ghcDir = ghcDirLocation 29 | , ghcBinDir = ghcDirLocation "bin" 30 | } 31 | 32 | -- returns location of cabal's config file inside virtual environment dir structure 33 | cabalConfigLocation :: MyMonad FilePath 34 | cabalConfigLocation = do 35 | dirStructure <- vheDirStructure 36 | return $ cabalDir dirStructure "config" 37 | 38 | -- returns environment dictionary used in Virtual Haskell Environment 39 | -- it's inherited from the current process, but variable 40 | -- GHC_PACKAGE_PATH is altered. 41 | getVirtualEnvironment :: MyMonad [(String, String)] 42 | getVirtualEnvironment = do 43 | env <- liftIO getEnvironment 44 | dirStructure <- vheDirStructure 45 | return $ ("GHC_PACKAGE_PATH", ghcPackagePath dirStructure) : filter (\(k,_) -> k /= "GHC_PACKAGE_PATH") env 46 | -------------------------------------------------------------------------------- /src/Types.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 2 | module Types ( GhcSource(..) 3 | , Options(..) 4 | , MyState(..) 5 | , DirStructure(..) 6 | , MyException(..) 7 | , Verbosity(..) 8 | ) where 9 | 10 | import Control.Monad.Error (Error) 11 | 12 | data GhcSource = System -- Use System's copy of GHC 13 | | Tarball FilePath -- Use GHC from tarball 14 | 15 | data Verbosity = Quiet 16 | | Verbose 17 | | VeryVerbose 18 | deriving (Eq, Ord) 19 | 20 | data Options = Options { verbosity :: Verbosity 21 | , skipSanityCheck :: Bool 22 | , vheName :: String -- Virtual Haskell Environment name 23 | , ghcSource :: GhcSource 24 | , makeCmd :: String -- make substitute used for 'make install' of external GHC 25 | } 26 | 27 | data MyState = MyState { logDepth :: Integer -- used for indentation of logging messages 28 | } 29 | 30 | newtype MyException = MyException { getExceptionMessage :: String } 31 | deriving Error 32 | 33 | -- Only absolute paths! 34 | data DirStructure = DirStructure { virthualEnv :: FilePath -- dir containing .virthualenv dir (usually dir with cabal project) 35 | , virthualEnvDir :: FilePath -- .virthualenv dir 36 | , ghcPackagePath :: FilePath -- file (=ghc-6.12) containing private GHC pkg db 37 | , cabalDir :: FilePath -- directory with private cabal dir 38 | , cabalBinDir :: FilePath -- cabal's bin/ dir (used in $PATH) 39 | , virthualEnvBinDir :: FilePath -- dir with haskell tools wrappers and activate script 40 | , ghcDir :: FilePath -- directory with private copy of external GHC (only used when using GHC from tarball) 41 | , ghcBinDir :: FilePath -- ghc's bin/ dir (with ghc[i|-pkg]) (only used when using GHC from tarball) 42 | } 43 | -------------------------------------------------------------------------------- /src/SanityCheck.hs: -------------------------------------------------------------------------------- 1 | module SanityCheck (sanityCheck) where 2 | 3 | import Control.Monad (when) 4 | import System.Directory (doesDirectoryExist) 5 | 6 | import Util.IO (getEnvVar, which) 7 | import Types 8 | import MyMonad 9 | import Paths (vheDirStructure) 10 | 11 | -- check if any virtual env is already active 12 | checkVHE :: MyMonad () 13 | checkVHE = do 14 | virthualEnvVar <- liftIO $ getEnvVar "VIRTHUALENV" 15 | case virthualEnvVar of 16 | Nothing -> return () 17 | Just path -> do 18 | virthualEnvName <- liftIO $ getEnvVar "VIRTHUALENV_NAME" 19 | case virthualEnvName of 20 | Nothing -> do 21 | debug $ "warning: VIRTHUALENV environment variable is defined" ++ ", but no VIRHTUALENV_NAME environment variable defined." 22 | throwError $ MyException $ "There is already active Virtual Haskell Environment (at " ++ path ++ ")." 23 | Just name -> 24 | throwError $ MyException $ "There is already active " ++ name ++ " Virtual Haskell Environment (at " ++ path ++ ")." 25 | 26 | checkVirthualEnvAlreadyExists :: MyMonad () 27 | checkVirthualEnvAlreadyExists = do 28 | dirStructure <- vheDirStructure 29 | flag <- liftIO $ doesDirectoryExist $ virthualEnvDir dirStructure 30 | when flag $ throwError $ MyException $ "There is already .virthualenv directory at " ++ virthualEnv dirStructure 31 | 32 | -- check if cabal binary exist on PATH 33 | checkCabalInstall :: MyMonad () 34 | checkCabalInstall = do 35 | cabalInstallPath <- liftIO $ which "cabal" 36 | case cabalInstallPath of 37 | Just _ -> return () 38 | Nothing -> throwError $ MyException "Couldn't find cabal binary (from cabal-install package) in your $PATH." 39 | 40 | -- check if GHC tools (ghc, ghc-pkg) exist on PATH 41 | -- skip the check if using GHC from a tarball 42 | checkGhc :: MyMonad () 43 | checkGhc = do 44 | ghcSrc <- asks ghcSource 45 | case ghcSrc of 46 | Tarball _ -> return () 47 | System -> do 48 | ghcPath <- liftIO $ which "ghc" 49 | case ghcPath of 50 | Just _ -> return () 51 | Nothing -> throwError $ MyException "Couldn't find ghc binary in your $PATH." 52 | ghc_pkgPath <- liftIO $ which "ghc-pkg" 53 | case ghc_pkgPath of 54 | Just _ -> return () 55 | Nothing -> throwError $ MyException "Couldn't find ghc-pkg binary in your $PATH." 56 | 57 | -- check if everything is sane 58 | sanityCheck :: MyMonad () 59 | sanityCheck = do 60 | checkVHE 61 | checkVirthualEnvAlreadyExists 62 | checkCabalInstall 63 | checkGhc 64 | -------------------------------------------------------------------------------- /src/Util/Tar.hs: -------------------------------------------------------------------------------- 1 | module Util.Tar ( unpack 2 | , stripComponents 3 | ) where 4 | 5 | import Codec.Archive.Tar.Entry 6 | import Codec.Archive.Tar (Entries(..), mapEntries) 7 | import Codec.Archive.Tar.Check (checkSecurity) 8 | 9 | import qualified Data.ByteString.Lazy as BS 10 | import System.FilePath ((), splitPath, joinPath, hasTrailingPathSeparator) 11 | import qualified System.FilePath as FilePath.Native (takeDirectory) 12 | import System.Directory (createDirectoryIfMissing, copyFile) 13 | import Control.Monad (when) 14 | import System.Posix.Files (ownerExecuteMode, intersectFileModes) 15 | 16 | import Util.IO (makeExecutable) 17 | 18 | isExecutable :: Permissions -> Bool 19 | isExecutable perms = intersectFileModes ownerExecuteMode perms == ownerExecuteMode 20 | 21 | unpack :: FilePath -> Entries -> IO () 22 | unpack baseDir entries = unpackEntries [] (checkSecurity entries) 23 | >>= emulateLinks 24 | 25 | where 26 | unpackEntries _ (Fail err) = fail err 27 | unpackEntries links Done = return links 28 | unpackEntries links (Next entry es) = case entryContent entry of 29 | NormalFile file _ -> extractFile path file (entryPermissions entry) 30 | >> unpackEntries links es 31 | Directory -> extractDir path 32 | >> unpackEntries links es 33 | HardLink link -> (unpackEntries $! saveLink path link links) es 34 | SymbolicLink link -> (unpackEntries $! saveLink path link links) es 35 | _ -> unpackEntries links es --ignore other file types 36 | where 37 | path = entryPath entry 38 | 39 | extractFile path content perms = do 40 | createDirectoryIfMissing True absDir 41 | BS.writeFile absPath content 42 | when (isExecutable perms) $ makeExecutable absPath 43 | where 44 | absDir = baseDir FilePath.Native.takeDirectory path 45 | absPath = baseDir path 46 | 47 | extractDir path = createDirectoryIfMissing True (baseDir path) 48 | 49 | saveLink path link links = seq (length path) 50 | $ seq (length link') 51 | $ (path, link'):links 52 | where link' = fromLinkTarget link 53 | 54 | emulateLinks = mapM_ $ \(relPath, relLinkTarget) -> 55 | let absPath = baseDir relPath 56 | absTarget = FilePath.Native.takeDirectory absPath relLinkTarget 57 | in copyFile absTarget absPath 58 | 59 | stripComponents :: Int -> Entries -> Entries 60 | stripComponents n = mapEntries aux 61 | where aux entry@Entry{entryTarPath = oldTarPath} = 62 | let isDirectory = hasTrailingPathSeparator $ fromTarPath oldTarPath 63 | in case toTarPath isDirectory $ joinPath $ drop n $ splitPath $ fromTarPath oldTarPath of 64 | Left err -> Left err 65 | Right newTarPath -> Right entry{entryTarPath = newTarPath} 66 | -------------------------------------------------------------------------------- /src/MyMonad.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 2 | module MyMonad ( MyMonad 3 | , runMyMonad 4 | , indentMessages 5 | , debug 6 | , info 7 | , trace 8 | , warning 9 | , finally 10 | , throwError 11 | , catchError 12 | , asks 13 | , gets 14 | , tell 15 | , modify 16 | , liftIO 17 | ) where 18 | 19 | import Types 20 | 21 | import Control.Monad.Trans (MonadIO, liftIO) 22 | import Control.Monad.Reader (ReaderT, MonadReader, runReaderT, asks) 23 | import Control.Monad.Writer (WriterT, MonadWriter, runWriterT, tell) 24 | import Control.Monad.State (StateT, MonadState, evalStateT, modify, gets) 25 | import Control.Monad.Error (ErrorT, MonadError, runErrorT, throwError, catchError) 26 | import Control.Monad (when) 27 | import System.IO (stderr, hPutStrLn) 28 | 29 | import Prelude hiding (log) 30 | 31 | newtype MyMonad a = MyMonad (StateT MyState (ReaderT Options (ErrorT MyException (WriterT [String] IO))) a) 32 | deriving (Functor, Monad, MonadReader Options, MonadState MyState, MonadError MyException, MonadWriter [String]) 33 | 34 | instance MonadIO MyMonad where 35 | liftIO m = MyMonad $ do 36 | x <- liftIO $ (Right `fmap` m) `catch` (return . Left) 37 | case x of 38 | Left e -> throwError $ MyException $ "IO error: " ++ show e 39 | Right y -> return y 40 | 41 | runMyMonad :: MyMonad a -> Options -> IO (Either MyException a, [String]) 42 | runMyMonad (MyMonad m) = runWriterT . runErrorT . runReaderT (evalStateT m (MyState 0)) 43 | 44 | finally :: MyMonad a -> MyMonad b -> MyMonad a 45 | finally m sequel = do 46 | result <- (Right `fmap` m) `catchError` (return . Left) 47 | _ <- sequel 48 | case result of 49 | Left e -> throwError e 50 | Right x -> return x 51 | 52 | indentMessages :: MyMonad a -> MyMonad a 53 | indentMessages m = do 54 | modify (\s -> s{logDepth = logDepth s + 2}) 55 | result <- m 56 | modify (\s -> s{logDepth = logDepth s - 2}) 57 | return result 58 | 59 | -- add message to private log and return adjusted message (with log depth) 60 | -- that can be printed somewhere else 61 | privateLog :: String -> MyMonad String 62 | privateLog str = do 63 | depth <- gets logDepth 64 | let text = replicate (fromInteger depth) ' ' ++ str 65 | tell [text] 66 | return text 67 | 68 | log :: Verbosity -> String -> MyMonad () 69 | log minLevel str = do 70 | text <- privateLog str 71 | flag <- asks verbosity 72 | when (flag >= minLevel) $ 73 | liftIO $ putStrLn text 74 | 75 | debug :: String -> MyMonad () 76 | debug = log Verbose 77 | 78 | info :: String -> MyMonad () 79 | info = log Quiet 80 | 81 | trace :: String -> MyMonad () 82 | trace = log VeryVerbose 83 | 84 | warning :: String -> MyMonad () 85 | warning str = do 86 | text <- privateLog str 87 | liftIO $ hPutStrLn stderr text 88 | -------------------------------------------------------------------------------- /src/Util/IO.hs: -------------------------------------------------------------------------------- 1 | module Util.IO ( getEnvVar 2 | , makeExecutable 3 | , readProcessWithExitCodeInEnv 4 | , Environment 5 | , createTemporaryDirectory 6 | , which 7 | ) where 8 | 9 | import System.Environment (getEnv) 10 | import System.IO.Error (isDoesNotExistError) 11 | import System.Directory (getPermissions, setPermissions, executable, removeFile, createDirectory, doesFileExist) 12 | import Control.Concurrent (forkIO, putMVar, takeMVar, newEmptyMVar) 13 | import Control.Exception (evaluate) 14 | import System.Process (runInteractiveProcess, waitForProcess) 15 | import System.IO (hGetContents, hPutStr, hFlush, hClose, openTempFile) 16 | import System.Exit (ExitCode) 17 | import Data.List.Split (splitOn) 18 | import Control.Monad (foldM) 19 | import System.FilePath (()) 20 | 21 | -- Computation getEnvVar var returns Just the value of the environment variable var, 22 | -- or Nothing if the environment variable does not exist 23 | getEnvVar :: String -> IO (Maybe String) 24 | getEnvVar var = Just `fmap` getEnv var `catch` noValueHandler 25 | where noValueHandler e | isDoesNotExistError e = return Nothing 26 | | otherwise = ioError e 27 | 28 | makeExecutable :: FilePath -> IO () 29 | makeExecutable path = do 30 | perms <- getPermissions path 31 | setPermissions path perms{executable = True} 32 | 33 | type Environment = [(String, String)] 34 | 35 | -- like readProcessWithExitCode, but takes additional environment argument 36 | readProcessWithExitCodeInEnv :: Environment -> FilePath -> [String] -> Maybe String -> IO (ExitCode, String, String) 37 | readProcessWithExitCodeInEnv env progName args input = do 38 | (inh, outh, errh, pid) <- runInteractiveProcess progName args Nothing (Just env) 39 | out <- hGetContents outh 40 | outMVar <- newEmptyMVar 41 | _ <- forkIO $ evaluate (length out) >> putMVar outMVar () 42 | err <- hGetContents errh 43 | errMVar <- newEmptyMVar 44 | _ <- forkIO $ evaluate (length err) >> putMVar errMVar () 45 | case input of 46 | Just inp | not (null inp) -> hPutStr inh inp >> hFlush inh 47 | _ -> return () 48 | hClose inh 49 | takeMVar outMVar 50 | hClose outh 51 | takeMVar errMVar 52 | hClose errh 53 | ex <- waitForProcess pid 54 | return (ex, out, err) 55 | 56 | -- similar to openTempFile, but creates a temporary directory 57 | -- and returns its path 58 | createTemporaryDirectory :: FilePath -> String -> IO FilePath 59 | createTemporaryDirectory parentDir templateName = do 60 | (path, handle) <- openTempFile parentDir templateName 61 | hClose handle 62 | removeFile path 63 | createDirectory path 64 | return path 65 | 66 | which :: String -> IO (Maybe FilePath) 67 | which name = do 68 | path <- getEnvVar "PATH" 69 | case path of 70 | Nothing -> return Nothing 71 | Just path' -> do 72 | let pathElems = splitOn ":" path' 73 | aux x@(Just _) _ = return x 74 | aux Nothing pathDir = do 75 | let programPath = pathDir name 76 | flag <- doesFileExist programPath 77 | if flag then 78 | return $ Just programPath 79 | else 80 | return Nothing 81 | foldM aux Nothing pathElems 82 | -------------------------------------------------------------------------------- /src/Process.hs: -------------------------------------------------------------------------------- 1 | module Process ( externalGhcPkgDb 2 | , outsideGhcPkg 3 | , insideGhcPkg 4 | , runProcess 5 | , ghcPkgDbPathLocation 6 | ) where 7 | 8 | import Types 9 | import MyMonad 10 | import Paths 11 | 12 | import Util.IO (readProcessWithExitCodeInEnv, Environment) 13 | 14 | import Control.Monad (forM_) 15 | import Data.Maybe (fromMaybe) 16 | import System.FilePath (()) 17 | import System.Process (readProcessWithExitCode) 18 | import System.Exit (ExitCode(..)) 19 | 20 | runProcess :: Maybe Environment -> FilePath -> [String] -> Maybe String -> MyMonad String 21 | runProcess env prog args input = do 22 | debug $ unwords $ ["Executing:", prog] ++ args 23 | indentMessages $ case env of 24 | Nothing -> trace "using inherited variable environment" 25 | Just env' -> do 26 | trace "using following environment:" 27 | indentMessages $ forM_ env' $ \(var,val) -> trace $ var ++ ": " ++ val 28 | indentMessages $ case input of 29 | Nothing -> return () 30 | Just inp -> do 31 | trace "using the following input:" 32 | indentMessages $ forM_ (lines inp) trace 33 | let execProcess = case env of 34 | Nothing -> readProcessWithExitCode prog args (fromMaybe "" input) 35 | Just env' -> readProcessWithExitCodeInEnv env' prog args input 36 | (exitCode, output, errors) <- liftIO execProcess 37 | indentMessages $ debug $ case exitCode of 38 | ExitSuccess -> "Process exited successfully" 39 | ExitFailure errCode -> "Process failed with exit code " ++ show errCode 40 | indentMessages $ do 41 | trace "Process output:" 42 | indentMessages $ forM_ (lines output) trace 43 | indentMessages $ do 44 | trace "Process error output:" 45 | indentMessages $ forM_ (lines errors) trace 46 | case exitCode of 47 | ExitSuccess -> return output 48 | ExitFailure errCode -> throwError $ MyException $ prog ++ " process failed with status " ++ show errCode 49 | 50 | -- run outside ghc-pkg tool (uses system's or from ghc installed from tarball) 51 | outsideGhcPkg :: [String] -> MyMonad String 52 | outsideGhcPkg args = do 53 | ghc <- asks ghcSource 54 | dirStructure <- vheDirStructure 55 | ghcPkg <- case ghc of 56 | System -> do 57 | debug "Running system's version of ghc-pkg" 58 | return "ghc-pkg" 59 | Tarball _ -> do 60 | debug "Running ghc-pkg installed from GHC's tarball" 61 | return $ ghcDir dirStructure "bin" "ghc-pkg" 62 | indentMessages $ runProcess Nothing ghcPkg args Nothing 63 | 64 | -- returns path to GHC (installed from tarball) builtin package database 65 | externalGhcPkgDb :: MyMonad FilePath 66 | externalGhcPkgDb = do 67 | debug "Checking where GHC (installed from tarball) keeps its package database" 68 | out <- indentMessages $ outsideGhcPkg ["list"] 69 | indentMessages $ debug "Trying to parse ghc-pkg's output" 70 | case lines out of 71 | [] -> throwError $ MyException "ghc-pkg returned empty output" 72 | lineWithPath:_ -> 73 | case lineWithPath of 74 | "" -> throwError $ MyException "ghc-pkg's first line of output is empty" 75 | _ -> do 76 | -- ghc-pkg ends pkg db path with trailing colon 77 | -- but only when not run from the terminal 78 | let path = init lineWithPath 79 | indentMessages $ debug $ "Found: " ++ path 80 | return path 81 | 82 | -- run ghc-pkg tool (uses system's or from ghc installed from tarball) 83 | -- from the inside of Virtual Haskell Environment 84 | insideGhcPkg :: [String] -> Maybe String -> MyMonad String 85 | insideGhcPkg args input = do 86 | ghc <- asks ghcSource 87 | dirStructure <- vheDirStructure 88 | env <- getVirtualEnvironment 89 | ghcPkg <- case ghc of 90 | System -> do 91 | debug "Running system's version of ghc-pkg inside virtual environment" 92 | return "ghc-pkg" 93 | Tarball _ -> do 94 | debug "Running ghc-pkg, installed from GHC's tarball, inside virtual environment" 95 | return $ ghcDir dirStructure "bin" "ghc-pkg" 96 | indentMessages $ runProcess (Just env) ghcPkg args input 97 | 98 | -- returns value of GHC_PACKAGE_PATH that should be used inside virtual environment 99 | ghcPkgDbPathLocation :: MyMonad String 100 | ghcPkgDbPathLocation = do 101 | debug "Determining value of GHC_PACKAGE_PATH to be used inside virtual environment" 102 | dirStructure <- vheDirStructure 103 | ghc <- asks ghcSource 104 | case ghc of 105 | System -> return $ ghcPackagePath dirStructure 106 | Tarball _ -> do 107 | externalGhcPkgDbPath <- indentMessages externalGhcPkgDb 108 | return $ ghcPackagePath dirStructure ++ ":" ++ externalGhcPkgDbPath 109 | -------------------------------------------------------------------------------- /src/PackageManagement.hs: -------------------------------------------------------------------------------- 1 | module PackageManagement ( Transplantable(..) 2 | , parseVersion 3 | , parsePkgInfo 4 | ) where 5 | 6 | import Distribution.Package (PackageIdentifier(..), PackageName(..)) 7 | import Distribution.Version (Version(..)) 8 | import Control.Monad (unless) 9 | 10 | import Types 11 | import MyMonad 12 | import Process (outsideGhcPkg, insideGhcPkg) 13 | import Util.Cabal (prettyPkgInfo, prettyVersion) 14 | import qualified Util.Cabal (parseVersion, parsePkgInfo) 15 | 16 | parseVersion :: String -> MyMonad Version 17 | parseVersion s = case Util.Cabal.parseVersion s of 18 | Nothing -> throwError $ MyException $ "Couldn't parse " ++ s ++ " as a package version" 19 | Just version -> return version 20 | 21 | parsePkgInfo :: String -> MyMonad PackageIdentifier 22 | parsePkgInfo s = case Util.Cabal.parsePkgInfo s of 23 | Nothing -> throwError $ MyException $ "Couldn't parse package identifier " ++ s 24 | Just pkgInfo -> return pkgInfo 25 | 26 | getDeps :: PackageIdentifier -> MyMonad [PackageIdentifier] 27 | getDeps pkgInfo = do 28 | let prettyPkg = prettyPkgInfo pkgInfo 29 | debug $ "Extracting dependencies of " ++ prettyPkg 30 | out <- indentMessages $ outsideGhcPkg ["field", prettyPkg, "depends"] 31 | -- example output: 32 | -- depends: ghc-prim-0.2.0.0-3fbcc20c802efcd7c82089ec77d92990 33 | -- integer-gmp-0.2.0.0-fa82a0df93dc30b4a7c5654dd7c68cf4 builtin_rts 34 | case words out of 35 | [] -> throwError $ MyException $ "Couldn't parse ghc-pkg output to find dependencies of " ++ prettyPkg 36 | _:depStrings -> do -- skip 'depends:' 37 | indentMessages $ trace $ "Found dependency strings: " ++ unwords depStrings 38 | mapM parsePkgInfo depStrings 39 | 40 | -- things that can be copied from system's GHC pkg database 41 | -- to GHC pkg database inside virtual environment 42 | class Transplantable a where 43 | transplantPackage :: a -> MyMonad () 44 | 45 | -- choose the highest installed version of package with this name 46 | instance Transplantable PackageName where 47 | transplantPackage (PackageName packageName) = do 48 | debug $ "Copying package " ++ packageName ++ " to Virtual Haskell Environment." 49 | indentMessages $ do 50 | debug "Choosing package with highest version number." 51 | out <- indentMessages $ outsideGhcPkg ["field", packageName, "version"] 52 | -- example output: 53 | -- version: 1.1.4 54 | -- version: 1.2.0.3 55 | let extractVersionString :: String -> MyMonad String 56 | extractVersionString line = case words line of 57 | [_, x] -> return x 58 | _ -> throwError $ MyException $ "Couldn't extract version string from: " ++ line 59 | versionStrings <- mapM extractVersionString $ lines out 60 | indentMessages $ trace $ "Found version strings: " ++ unwords versionStrings 61 | versions <- mapM parseVersion versionStrings 62 | case versions of 63 | [] -> throwError $ MyException $ "No versions of package " ++ packageName ++ " found" 64 | (v:vs) -> do 65 | indentMessages $ debug $ "Found: " ++ unwords (map prettyVersion versions) 66 | let highestVersion = foldr max v vs 67 | indentMessages $ debug $ "Using version: " ++ prettyVersion highestVersion 68 | let pkgInfo = PackageIdentifier (PackageName packageName) highestVersion 69 | transplantPackage pkgInfo 70 | 71 | -- check if this package is already installed in Virtual Haskell Environment 72 | checkIfInstalled :: PackageIdentifier -> MyMonad Bool 73 | checkIfInstalled pkgInfo = do 74 | let package = prettyPkgInfo pkgInfo 75 | debug $ "Checking if " ++ package ++ " is already installed." 76 | (do 77 | _ <- indentMessages $ insideGhcPkg ["describe", package] Nothing 78 | indentMessages $ debug "It is." 79 | return True) `catchError` handler 80 | where handler _ = do 81 | debug "It's not." 82 | return False 83 | 84 | instance Transplantable PackageIdentifier where 85 | transplantPackage pkgInfo = do 86 | let prettyPkg = prettyPkgInfo pkgInfo 87 | debug $ "Copying package " ++ prettyPkg ++ " to Virtual Haskell Environment." 88 | indentMessages $ do 89 | flag <- checkIfInstalled pkgInfo 90 | unless flag $ do 91 | deps <- getDeps pkgInfo 92 | debug $ "Found: " ++ unwords (map prettyPkgInfo deps) 93 | mapM_ transplantPackage deps 94 | movePackage pkgInfo 95 | 96 | -- copy single package that already has all deps satisfied 97 | movePackage :: PackageIdentifier -> MyMonad () 98 | movePackage pkgInfo = do 99 | let prettyPkg = prettyPkgInfo pkgInfo 100 | debug $ "Moving package " ++ prettyPkg ++ " to Virtual Haskell Environment." 101 | out <- outsideGhcPkg ["describe", prettyPkg] 102 | _ <- insideGhcPkg ["register", "-"] (Just out) 103 | return () 104 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | Virtual Haskell Environment 2 | =========================== 3 | 4 | virthualenv is deprecated, please use the hsenv tool. 5 | 6 | What is it? 7 | ----------- 8 | virthualenv is a tool (inspired by Python's virtualenv) 9 | to create isolated Haskell environments. 10 | 11 | 12 | What does it do? 13 | ---------------- 14 | It creates a sandboxed environment in a .virthualenv/ sub-directory 15 | of your project, which, when activated, allows you to use regular Haskell tools 16 | (ghc, ghci, ghc-pkg, cabal) to manage your Haskell code and environment. 17 | It's possible to create an environment, that uses different GHC version 18 | than your currently installed. Very simple emacs integration mode is included. 19 | 20 | Basic usage 21 | ----------- 22 | First, choose a directory where you want to keep your 23 | sandboxed Haskell environment, usually a good choice is a directory containing 24 | your cabalized project (if you want to work on a few projects 25 | (perhaps an app and its dependent library), just choose any of them, 26 | it doesn't really matter). Enter that directory: 27 | 28 | > cd ~/projects/foo 29 | 30 | Next, create your new isolated Haskell environment 31 | (this is a one time only (per environment) step): 32 | 33 | > virthualenv 34 | 35 | Now, every time you want to use this environment, you have to activate it: 36 | 37 | > source .virthualenv/bin/activate 38 | 39 | That's it! Now it's possible to use all regular Haskell tools like usual, 40 | but it won't affect your global/system's Haskell environment, and also 41 | your per-user environment (from ~/.cabal and ~/.ghc) will stay the same. 42 | All cabal-installed packages will be private to this environment, 43 | and also the external environments (global and user) will not affect it 44 | (this environment will only inherit very basic packages, 45 | mostly ghc and Cabal and their deps). 46 | 47 | When you're done working with this environment, enter command 'deactivate', 48 | or just close the current shell (with exit). 49 | 50 | > deactivate 51 | 52 | Advanced usage 53 | -------------- 54 | Here's the most advanced usage of virthualenv. Let's say you want to: 55 | 56 | * hack on json library 57 | * do so comfortably 58 | * use your own version of parsec library 59 | * and do all this using nightly version of GHC 60 | 61 | First, download binary distribution of GHC for your platform 62 | (e.g. ghc-7.3.20111105-i386-unknown-linux.tar.bz2). 63 | 64 | Create a directory for you environment: 65 | 66 | > mkdir /tmp/test; cd /tmp/test 67 | 68 | Then, create a new environment using that GHC: 69 | 70 | > virthualenv --ghc=/path/to/ghc-7.3.20111105-i386-unknown-linux.tar.bz2 71 | 72 | Activate it: 73 | 74 | > source .virthualenv/bin/activate 75 | 76 | Download a copy of json library and your private version of parsec: 77 | 78 | > darcs get http://patch-tag.com/r/Paczesiowa/parsec; cabal unpack json 79 | 80 | Install parsec: 81 | 82 | > cd parsec2; cabal install 83 | 84 | Install the rest of json deps: 85 | 86 | > cd ../json-0.5; cabal install --only-dependencies 87 | 88 | Now, let's say you want to hack on Parsec module of json library. 89 | Open it in emacs: 90 | 91 | > emacsclient Text/JSON/Parsec.hs 92 | 93 | Activate the virtual environment (virthualenv must be required earlier): 94 | 95 | > M-x virthualenv-activate /tmp/test/ 96 | 97 | Edit some code and load it in ghci using 'C-c C-l'. If it type checks, 98 | you can play around with the code using nightly version of ghci running 99 | in your virtual environment. When you're happy with the code, exit emacs 100 | and install your edited json library: 101 | 102 | > cabal install 103 | 104 | And that's it. 105 | 106 | Misc 107 | ---- 108 | virthualenv has been tested on i386 Linux and FreeBSD systems, 109 | but it should work on any Posix platform. External (from tarball) GHC feature 110 | requires binary GHC distribution compiled for your platform, 111 | that can be extracted with tar and installed with 112 | "./configure --prefix=PATH; make install". 113 | 114 | FAQ 115 | --- 116 | Q: Can I use it together with tools like cabal-dev or capri? 117 | A: No. All these tools work more or less the same (wrapping cabal command, 118 | setting GHC_PACKAGE_PATH env variable), so something will probably break. 119 | 120 | Q: Using GHC from tarball fails, when using FreeBSD with a bunch of make tool 121 | gibberish. What do I do? 122 | A: Try '--make-cmd=gmake' switch. 123 | 124 | Q: Can I use virthualenv inside virthualenv? 125 | A: No. It may be supported in future versions. 126 | 127 | Q: Does it work on x64 systems? 128 | A: It hasn't been tested, but there's no reason why it shouldn't. 129 | 130 | Q: Will it work on Mac? 131 | A: I doubt it. It should be easy to make it work there with system's GHC, 132 | Using GHC from tarball will be probably harder. I don't have any mac 133 | machines, so you're on your own, but patches/ideas/questions are welcome. 134 | 135 | Q: Will it work on Windows? 136 | A: I really doubt it would even compile. I don't have access to any windows 137 | machines, so you're on your own, but patches/ideas/questions are welcome. 138 | Maybe it would work on cygwin. 139 | 140 | Q: Does it require bash? 141 | A: No, it should work with any POSIX-compliant shell. It's been tested with 142 | bash, bash --posix, dash, zsh and ksh. 143 | 144 | Q: Can I use it with a different haskell package repository than hackage? 145 | A: Yes, just adjust the url in .virthualenv/cabal/config file. 146 | 147 | Q: How do I remove the whole virtual environment? 148 | A: If it's activated - 'deactivate' it. Then, delete 149 | the .virthualenv/ directory. 150 | 151 | Q: Is every environment completely separate from other environments and 152 | the system environment? 153 | A: Yes. The only (minor) exception is ghci history - there's only one 154 | per user history file. Also, if you alter your system's GHC, then 155 | virtual environments using system's GHC copy will probably break. 156 | Virtual environments using GHC from a tarball should continue to work. 157 | -------------------------------------------------------------------------------- /virthualenv.cabal: -------------------------------------------------------------------------------- 1 | Name: virthualenv 2 | 3 | Version: 0.2.2 4 | 5 | Synopsis: Virtual Haskell Environment builder 6 | 7 | Description: virthualenv is a tool (inspired by Python's virtualenv) to create isolated Haskell environments. 8 | . 9 | virthualenv is deprecated, please use the hsenv tool. 10 | . 11 | It creates a sandboxed environment in a .virthualenv/ directory, which, when activated, 12 | allows you to use regular Haskell tools (ghc, ghci, ghc-pkg, cabal) to manage your Haskell 13 | code and environment. It's possible to create an environment, that uses different GHC version 14 | than your currently installed. virthualenv is supposed to be easier to learn (and use) than 15 | similar packages (like cabal-dev or capri). 16 | . 17 | Basic usage. 18 | . 19 | First, choose a directory where you want to keep your sandboxed Haskell environment, 20 | usually a good choice is a directory containing your cabalized project (if you want to work 21 | on a few projects (perhaps an app and its dependent library), just choose any of them, 22 | it doesn't really matter). Enter that directory: 23 | . 24 | > cd ~/projects/foo 25 | . 26 | Next, create your new isolated Haskell environment (this is a one time only (per environment) step): 27 | . 28 | > virthualenv 29 | . 30 | Now, every time you want to use this enviroment, you have to activate it: 31 | . 32 | > source .virthualenv/bin/activate 33 | . 34 | That's it! Now it's possible to use all regular Haskell tools like usual, but it won't affect 35 | your global/system's Haskell environment, and also your per-user environment (from ~/.cabal and 36 | ~/.ghc) will stay the same. All cabal-installed packages will be private to this environment, 37 | and also the external environments (global and user) will not affect it (this environment 38 | will only inherit very basic packages - mostly ghc and Cabal and their deps). 39 | . 40 | When you're done working with this environment, enter command 'deactivate', 41 | or just close the current shell (with exit). 42 | . 43 | > deactivate 44 | . 45 | Advanced usage. 46 | . 47 | The only advanced usage is using different GHC version. This can be useful to test your code 48 | against different GHC version (even against nightly builds). 49 | . 50 | First, download binary distribution of GHC for your platform 51 | (e.g. ghc-7.0.4-i386-unknown-linux.tar.bz2), then create a new environment using that GHC 52 | . 53 | > virthualenv --ghc=/path/to/ghc_something.tar.bz2 54 | . 55 | Then, proceed (with [de]activation) as in basic case. 56 | . 57 | Misc. 58 | . 59 | virthualenv has been tested on i386 Linux systems, but it should work on any Posix platform. 60 | External (from tarball) GHC feature requires binary GHC distribution compiled for your platform, 61 | that can be extracted with tar and installed with "./configure --prefix=PATH; make install". 62 | . 63 | For more info please consult "virthualenv --help" or the attached README file. 64 | 65 | Homepage: https://github.com/Paczesiowa/virthualenv 66 | 67 | License: BSD3 68 | 69 | License-file: LICENSE 70 | 71 | Author: Bartosz Ćwikłowski 72 | 73 | Maintainer: paczesiowa@gmail.com 74 | 75 | Copyright: (c) 2011 Bartosz Ćwikłowski 76 | 77 | Category: Development 78 | 79 | Build-type: Simple 80 | 81 | Stability: alpha 82 | 83 | Bug-reports: https://github.com/Paczesiowa/virthualenv/issues 84 | 85 | Package-url: http://hackage.haskell.org/package/virthualenv 86 | 87 | Tested-with: GHC == 6.12.3, GHC == 7.0.4 88 | 89 | Data-files: virthualenv.el, README.md 90 | 91 | Extra-source-files: skeletons/activate, skeletons/cabal, skeletons/cabal_config 92 | 93 | Cabal-version: >=1.6 94 | 95 | Executable virthualenv 96 | 97 | Main-is: virthualenv.hs 98 | 99 | Hs-source-dirs: src 100 | 101 | Ghc-options: -threaded -Wall 102 | 103 | Build-depends: base >= 4.2.0.0 && < 4.6 104 | , process >= 1.0.1.2 && < 1.2 105 | , filepath >= 1.1.0.3 && < 1.4 106 | , directory >= 1.0.1.0 && < 1.2 107 | , Cabal >= 1.8.0.6 && < 1.15 108 | , mtl >= 1.1.0.2 && < 2.1 109 | , bytestring >= 0.9.1.7 && < 0.10 110 | , file-embed >= 0.0.4.1 && < 0.1 111 | , split >= 0.1.4 && < 0.2 112 | , safe >= 0.3 && < 0.4 113 | 114 | Other-modules: Util.Cabal 115 | , Util.Template 116 | , Util.IO 117 | , Skeletons 118 | , Types 119 | , MyMonad 120 | , Args 121 | , Paths 122 | , SanityCheck 123 | , Process 124 | , PackageManagement 125 | , Actions 126 | 127 | Source-repository head 128 | Type: git 129 | Location: git://github.com/Paczesiowa/virthualenv.git 130 | -------------------------------------------------------------------------------- /src/Args.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 2 | module Args ( usage 3 | , parseArgs 4 | ) where 5 | 6 | import System.Directory (getCurrentDirectory) 7 | import Data.List (isPrefixOf, isInfixOf) 8 | import Data.Char (isAlphaNum) 9 | import Data.Maybe (fromMaybe) 10 | import Control.Monad (when) 11 | import Data.Monoid (Monoid(..)) 12 | import System.Environment (getProgName) 13 | import System.FilePath (splitPath) 14 | import Control.Monad.Error (MonadError, ErrorT, runErrorT, throwError) 15 | import Control.Monad.State (MonadState, StateT, runStateT, get, put) 16 | import Control.Monad.Trans (MonadIO, liftIO) 17 | 18 | import Types 19 | 20 | usage :: IO () 21 | usage = do 22 | name <- getProgName 23 | putStrLn $ "usage: " ++ name ++ " [FLAGS]" 24 | putStrLn "" 25 | putStrLn "Flags:" 26 | putStrLn "-h --help Show this help message" 27 | putStrLn "--version Print version number" 28 | putStrLn "--verbose Print some debugging info" 29 | putStrLn "--very-verbose Print some debugging info" 30 | putStrLn "--skip-sanity-check Skip all the sanity checks (use at your own risk)" 31 | putStrLn "--name=NAME Use NAME for name of Virthual Haskell Environment" 32 | putStrLn " (defaults to the name of the current directory)" 33 | putStrLn "--ghc=FILE Use GHC from provided tarball (e.g. ghc-7.0.4-i386-unknown-linux.tar.bz2)" 34 | putStrLn " Without this flag virthualenv will use system's copy of GHC" 35 | putStrLn "--make-cmd=NAME Used as make substitute for installing GHC from tarball (e.g. gmake)," 36 | putStrLn " defaults to 'make'" 37 | putStrLn "" 38 | putStrLn "Creates Virtual Haskell Environment in the current directory." 39 | putStrLn "All files will be stored in the .virthualenv/ subdirectory." 40 | 41 | newtype ArgMonad a = ArgMonad (ErrorT String (StateT Args IO) a) 42 | deriving (MonadState Args, MonadError String, Monad, MonadIO) 43 | 44 | data Args = Args { shortArgs :: [Char] 45 | , longArgs :: [String] 46 | , longValArgs :: [(String, String)] 47 | , positionalArgs :: [String] 48 | } 49 | deriving Show 50 | 51 | emptyArgs :: Args 52 | emptyArgs = Args [] [] [] [] 53 | 54 | instance Monoid Args where 55 | mempty = Args [] [] [] [] 56 | Args x1 y1 z1 t1 `mappend` Args x2 y2 z2 t2 = Args (x1 ++ x2) (y1 ++ y2) (z1 ++ z2) (t1 ++ t2) 57 | 58 | runArgMonad :: ArgMonad a -> [String] -> IO (Either String a) 59 | runArgMonad (ArgMonad m) args = 60 | case parseArguments args of 61 | Left err -> return $ Left err 62 | Right parsedArgs -> do 63 | (result, leftOverArgs) <- runStateT (runErrorT m) parsedArgs 64 | case leftOverArgs of 65 | Args [] [] [] [] -> return result 66 | Args shortOptions _ _ _ | not (null shortOptions) -> 67 | return $ Left $ "Unknown short option identifiers: " ++ shortOptions 68 | Args _ longOptions _ _ | not (null longOptions) -> 69 | return $ Left $ "Unknown long option identifiers: " ++ unwords longOptions 70 | Args _ _ longKeyValOptions _ | not (null longKeyValOptions) -> 71 | return $ Left $ "Unknown long key-value options: " ++ unwords (map (\(k,v) -> k++"="++v) longKeyValOptions) 72 | Args _ _ _ _ -> return $ Left $ "Unknown positional options: " ++ unwords (positionalArgs leftOverArgs) 73 | 74 | parseArguments :: [String] -> Either String Args 75 | parseArguments args = 76 | case break (== "--") args of 77 | (keywordArgs, "--":rest) -> do 78 | parsedKeywordArgs <- mapM parseArgument keywordArgs 79 | return $ mconcat parsedKeywordArgs `mappend` emptyArgs{positionalArgs = rest} 80 | 81 | (_, []) -> mconcat `fmap` mapM parseArgument args 82 | _ -> error "I'm stupid and I cannot code. I'm sorry." 83 | 84 | parseArgument :: String -> Either String Args 85 | parseArgument arg | "--" `isPrefixOf` arg 86 | && "=" `isInfixOf` arg = 87 | let (x, y) = break (=='=') arg 88 | key = drop (length "--") x 89 | val = drop (length "=") y 90 | in return emptyArgs{longValArgs = [(key, val)]} 91 | | "--" `isPrefixOf` arg = 92 | return emptyArgs{longArgs = [drop (length "--") arg]} 93 | | "-" `isPrefixOf` arg = 94 | let symbols = tail arg 95 | in case symbols of 96 | [] -> throwError "Empty list of short options (after '-')" 97 | _ | any (not . isAlphaNum) symbols -> throwError "Non alpha-numeric short option" 98 | | otherwise -> return emptyArgs{shortArgs = symbols} 99 | | otherwise = return emptyArgs{positionalArgs = [arg]} 100 | 101 | getSingleLongValueArg :: String -> ArgMonad (Maybe String) 102 | getSingleLongValueArg argName = do 103 | args <- get 104 | case filter (\(k,_) -> k == argName) $ longValArgs args of 105 | [] -> return Nothing 106 | [(_, val)] -> do 107 | put args{longValArgs = filter (\(k,_) -> k /= argName) $ longValArgs args} 108 | return $ Just val 109 | _ -> throwError $ "Multiple values with key " ++ argName 110 | 111 | isSingleValueSet :: String -> ArgMonad Bool 112 | isSingleValueSet argName = do 113 | args <- get 114 | case filter (==argName) $ longArgs args of 115 | [] -> return False 116 | [_] -> do 117 | put args{longArgs = filter (/=argName) $ longArgs args} 118 | return True 119 | _ -> throwError $ "Multiple values named " ++ argName 120 | 121 | realParseArgs :: ArgMonad Options 122 | realParseArgs = do 123 | verbosityFlag <- isSingleValueSet "verbose" 124 | verbosityFlag2 <- isSingleValueSet "very-verbose" 125 | let verboseness = case (verbosityFlag, verbosityFlag2) of 126 | (_, True) -> VeryVerbose 127 | (True, False) -> Verbose 128 | (False, False) -> Quiet 129 | nameFlag <- getSingleLongValueArg "name" 130 | name <- case nameFlag of 131 | Just name' -> return name' 132 | Nothing -> do 133 | cwd <- liftIO getCurrentDirectory 134 | let dirs = splitPath cwd 135 | name = last dirs 136 | when (verboseness > Quiet) $ liftIO $ putStrLn $ "Using current directory name as Virtual Haskell Environment name: " ++ name 137 | return name 138 | ghcFlag <- getSingleLongValueArg "ghc" 139 | let ghc = case ghcFlag of 140 | Nothing -> System 141 | Just path -> Tarball path 142 | skipSanityCheckFlag <- isSingleValueSet "skip-sanity-check" 143 | makeCmdFlag <- getSingleLongValueArg "make-cmd" 144 | let make = fromMaybe "make" makeCmdFlag 145 | return Options{ verbosity = verboseness 146 | , skipSanityCheck = skipSanityCheckFlag 147 | , vheName = name 148 | , ghcSource = ghc 149 | , makeCmd = make 150 | } 151 | 152 | parseArgs :: [String] -> IO (Either String Options) 153 | parseArgs = runArgMonad realParseArgs 154 | -------------------------------------------------------------------------------- /src/Actions.hs: -------------------------------------------------------------------------------- 1 | module Actions ( cabalUpdate 2 | , installCabalConfig 3 | , installCabalWrapper 4 | , installActivateScript 5 | , copyBaseSystem 6 | , initGhcDb 7 | , installGhc 8 | , createDirStructure 9 | ) where 10 | 11 | import System.Directory (setCurrentDirectory, getCurrentDirectory, createDirectory, removeDirectoryRecursive) 12 | import System.FilePath (()) 13 | import Distribution.Version (Version (..)) 14 | import Distribution.Package (PackageName(..)) 15 | import Safe (lastMay) 16 | import Data.List (intercalate) 17 | 18 | import MyMonad 19 | import Types 20 | import Paths 21 | import PackageManagement 22 | import Process 23 | import Util.Template (substs) 24 | import Util.IO (makeExecutable, createTemporaryDirectory) 25 | import Skeletons 26 | 27 | -- update cabal package info inside Virtual Haskell Environmentn 28 | cabalUpdate :: MyMonad () 29 | cabalUpdate = do 30 | env <- getVirtualEnvironment 31 | cabalConfig <- cabalConfigLocation 32 | info "Updating cabal package database inside Virtual Haskell Environment." 33 | _ <- indentMessages $ runProcess (Just env) "cabal" ["--config-file=" ++ cabalConfig, "update"] Nothing 34 | return () 35 | 36 | -- install cabal wrapper (in bin/ directory) inside virtual environment dir structure 37 | installCabalWrapper :: MyMonad () 38 | installCabalWrapper = do 39 | cabalConfig <- cabalConfigLocation 40 | dirStructure <- vheDirStructure 41 | let cabalWrapper = virthualEnvBinDir dirStructure "cabal" 42 | info $ concat [ "Installing cabal wrapper using " 43 | , cabalConfig 44 | , " at " 45 | , cabalWrapper 46 | ] 47 | let cabalWrapperContents = substs [("", cabalConfig)] cabalWrapperSkel 48 | indentMessages $ do 49 | trace "cabal wrapper contents:" 50 | indentMessages $ mapM_ trace $ lines cabalWrapperContents 51 | liftIO $ writeFile cabalWrapper cabalWrapperContents 52 | liftIO $ makeExecutable cabalWrapper 53 | 54 | installActivateScriptSupportFiles :: MyMonad () 55 | installActivateScriptSupportFiles = do 56 | debug "installing supporting files" 57 | dirStructure <- vheDirStructure 58 | ghc <- asks ghcSource 59 | indentMessages $ do 60 | let pathVarPrependixLocation = virthualEnvDir dirStructure "path_var_prependix" 61 | pathVarElems = 62 | case ghc of 63 | System -> [virthualEnvBinDir dirStructure, cabalBinDir dirStructure] 64 | Tarball _ -> [ virthualEnvBinDir dirStructure 65 | , cabalBinDir dirStructure 66 | , ghcBinDir dirStructure 67 | ] 68 | pathVarPrependix = intercalate ":" pathVarElems 69 | debug $ "installing path_var_prependix file to " ++ pathVarPrependixLocation 70 | indentMessages $ trace $ "path_var_prependix contents: " ++ pathVarPrependix 71 | liftIO $ writeFile pathVarPrependixLocation pathVarPrependix 72 | ghcPkgDbPath <- indentMessages ghcPkgDbPathLocation 73 | let ghcPackagePathVarLocation = virthualEnvDir dirStructure "ghc_package_path_var" 74 | ghcPackagePathVar = ghcPkgDbPath 75 | debug $ "installing ghc_package_path_var file to " ++ ghcPackagePathVarLocation 76 | indentMessages $ trace $ "path_var_prependix contents: " ++ ghcPackagePathVar 77 | liftIO $ writeFile ghcPackagePathVarLocation ghcPackagePathVar 78 | 79 | -- install activate script (in bin/ directory) inside virtual environment dir structure 80 | installActivateScript :: MyMonad () 81 | installActivateScript = do 82 | info "Installing activate script" 83 | virthualEnvName <- asks vheName 84 | dirStructure <- vheDirStructure 85 | ghcPkgDbPath <- indentMessages ghcPkgDbPathLocation 86 | let activateScript = virthualEnvBinDir dirStructure "activate" 87 | indentMessages $ debug $ "using location: " ++ activateScript 88 | let activateScriptContents = substs [ ("", virthualEnvName) 89 | , ("", virthualEnvDir dirStructure) 90 | , ("", virthualEnv dirStructure) 91 | , ("", ghcPkgDbPath) 92 | , ("", virthualEnvBinDir dirStructure) 93 | , ("", cabalBinDir dirStructure) 94 | , ("", ghcBinDir dirStructure) 95 | ] activateSkel 96 | indentMessages $ do 97 | trace "activate script contents:" 98 | indentMessages $ mapM_ trace $ lines activateScriptContents 99 | liftIO $ writeFile activateScript activateScriptContents 100 | indentMessages installActivateScriptSupportFiles 101 | 102 | -- install cabal's config file (in cabal/ directory) inside virtual environment dir structure 103 | installCabalConfig :: MyMonad () 104 | installCabalConfig = do 105 | cabalConfig <- cabalConfigLocation 106 | dirStructure <- vheDirStructure 107 | info $ "Installing cabal config at " ++ cabalConfig 108 | let cabalConfigContents = substs [ ("", ghcPackagePath dirStructure) 109 | , ("", cabalDir dirStructure) 110 | ] cabalConfigSkel 111 | indentMessages $ do 112 | trace "cabal config contents:" 113 | indentMessages $ mapM_ trace $ lines cabalConfigContents 114 | liftIO $ writeFile cabalConfig cabalConfigContents 115 | 116 | createDirStructure :: MyMonad () 117 | createDirStructure = do 118 | dirStructure <- vheDirStructure 119 | info "Creating Virtual Haskell directory structure" 120 | indentMessages $ do 121 | debug $ "virthualenv directory: " ++ virthualEnvDir dirStructure 122 | liftIO $ createDirectory $ virthualEnvDir dirStructure 123 | debug $ "cabal directory: " ++ cabalDir dirStructure 124 | liftIO $ createDirectory $ cabalDir dirStructure 125 | debug $ "virthualenv bin directory: " ++ virthualEnvBinDir dirStructure 126 | liftIO $ createDirectory $ virthualEnvBinDir dirStructure 127 | 128 | -- initialize private GHC package database inside virtual environment 129 | initGhcDb :: MyMonad () 130 | initGhcDb = do 131 | dirStructure <- vheDirStructure 132 | info $ "Initializing GHC Package database at " ++ ghcPackagePath dirStructure 133 | out <- indentMessages $ outsideGhcPkg ["--version"] 134 | case lastMay $ words out of 135 | Nothing -> throwError $ MyException $ "Couldn't extract ghc-pkg version number from: " ++ out 136 | Just versionString -> do 137 | indentMessages $ trace $ "Found version string: " ++ versionString 138 | version <- parseVersion versionString 139 | let ghc_6_12_1_version = Version [6,12,1] [] 140 | if version < ghc_6_12_1_version then do 141 | indentMessages $ debug "Detected GHC older than 6.12, initializing GHC_PACKAGE_PATH to file with '[]'" 142 | liftIO $ writeFile (ghcPackagePath dirStructure) "[]" 143 | else do 144 | _ <- indentMessages $ outsideGhcPkg ["init", ghcPackagePath dirStructure] 145 | return () 146 | 147 | -- copy optional packages and don't fail completely if this copying fails 148 | -- some packages mail fail to copy and it's not fatal (e.g. older GHCs don't have haskell2010) 149 | transplantOptionalPackage :: String -> MyMonad () 150 | transplantOptionalPackage name = transplantPackage (PackageName name) `catchError` handler 151 | where handler e = do 152 | warning $ "Failed to copy optional package " ++ name ++ " from system's GHC: " 153 | indentMessages $ warning $ getExceptionMessage e 154 | 155 | -- copy base system 156 | -- base - needed for ghci and everything else 157 | -- Cabal - needed to install non-trivial cabal packages with cabal-install 158 | -- haskell98 - some packages need it but they don't specify it (seems it's an implicit dependancy) 159 | -- haskell2010 - maybe it's similar to haskell98? 160 | -- ghc and ghc-binary - two packages that are provided with GHC and cannot be installed any other way 161 | -- also include dependant packages of all the above 162 | -- when using GHC from tarball, just reuse its package database 163 | -- cannot do the same when using system's GHC, because there might be additional packages installed 164 | -- then it wouldn't be possible to work on them insie virtual environment 165 | copyBaseSystem :: MyMonad () 166 | copyBaseSystem = do 167 | info "Copying necessary packages from original GHC package database" 168 | indentMessages $ do 169 | ghc <- asks ghcSource 170 | case ghc of 171 | System -> do 172 | transplantPackage $ PackageName "base" 173 | transplantPackage $ PackageName "Cabal" 174 | mapM_ transplantOptionalPackage ["haskell98", "haskell2010", "ghc", "ghc-binary"] 175 | Tarball _ -> 176 | debug "Using external GHC - nothing to copy, Virtual environment will reuse GHC package database" 177 | 178 | installGhc :: MyMonad () 179 | installGhc = do 180 | info "Installing GHC" 181 | ghc <- asks ghcSource 182 | case ghc of 183 | System -> indentMessages $ debug "Using system version of GHC - nothing to install." 184 | Tarball tarballPath -> indentMessages $ installExternalGhc tarballPath 185 | 186 | installExternalGhc :: FilePath -> MyMonad () 187 | installExternalGhc tarballPath = do 188 | info $ "Installing GHC from " ++ tarballPath 189 | indentMessages $ do 190 | dirStructure <- vheDirStructure 191 | tmpGhcDir <- liftIO $ createTemporaryDirectory (virthualEnv dirStructure) "ghc" 192 | debug $ "Unpacking GHC tarball to " ++ tmpGhcDir 193 | _ <- indentMessages $ runProcess Nothing "tar" ["xf", tarballPath, "-C", tmpGhcDir, "--strip-components", "1"] Nothing 194 | let configureScript = tmpGhcDir "configure" 195 | debug $ "Configuring GHC with prefix " ++ ghcDir dirStructure 196 | cwd <- liftIO getCurrentDirectory 197 | liftIO $ setCurrentDirectory tmpGhcDir 198 | make <- asks makeCmd 199 | let configureAndInstall = do 200 | _ <- indentMessages $ runProcess Nothing configureScript ["--prefix=" ++ ghcDir dirStructure] Nothing 201 | debug $ "Installing GHC with " ++ make ++ " install" 202 | _ <- indentMessages $ runProcess Nothing make ["install"] Nothing 203 | return () 204 | configureAndInstall `finally` liftIO (setCurrentDirectory cwd) 205 | liftIO $ removeDirectoryRecursive tmpGhcDir 206 | return () 207 | --------------------------------------------------------------------------------