├── src ├── .ghci ├── Util │ ├── .ghci │ ├── Args │ │ ├── .ghci │ │ ├── ArgDescr.hs │ │ ├── ArgArrow.hs │ │ ├── RawArgs.hs │ │ ├── Usage.hs │ │ ├── Args.hs │ │ └── GetOpt.hs │ ├── String.hs │ ├── List.hs │ ├── Args.hs │ ├── Template.hs │ ├── WordWrap.hs │ ├── StaticArrowT.hs │ ├── Cabal.hs │ └── IO.hs ├── HsenvMonadUtils.hs ├── Skeletons.hs ├── hsenv.hs ├── Types.hs ├── SanityCheck.hs ├── HsenvMonad.hs ├── Paths.hs ├── PackageManagement.hs ├── Args.hs ├── Process.hs ├── CabalBootstrap.hs └── Actions.hs ├── .gitignore ├── Setup.hs ├── skeletons ├── cabal_config ├── ghc ├── ghci ├── runghc ├── ghc-mod ├── ghc-pkg ├── cabal └── activate ├── LICENSE ├── hsenv.el ├── hsenv.cabal └── README.md /src/.ghci: -------------------------------------------------------------------------------- 1 | :set -isrc/ 2 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | dist/ 2 | dist_*/ 3 | -------------------------------------------------------------------------------- /src/Util/.ghci: -------------------------------------------------------------------------------- 1 | :set -isrc/ 2 | -------------------------------------------------------------------------------- /src/Util/Args/.ghci: -------------------------------------------------------------------------------- 1 | :set -isrc/ 2 | -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /src/Util/String.hs: -------------------------------------------------------------------------------- 1 | module Util.String (padTo) where 2 | 3 | padTo :: String -> Int -> String 4 | padTo s n | length s < n = take n $ s ++ repeat ' ' 5 | | otherwise = s 6 | -------------------------------------------------------------------------------- /src/Util/List.hs: -------------------------------------------------------------------------------- 1 | module Util.List (breakOn) where 2 | 3 | breakOn :: Eq a => a -> [a] -> Maybe ([a], [a]) 4 | breakOn sep = aux [] 5 | where aux _ [] = Nothing 6 | aux prevs (x:xs) | x == sep = Just (reverse prevs, xs) 7 | | otherwise = aux (x:prevs) xs 8 | -------------------------------------------------------------------------------- /skeletons/cabal_config: -------------------------------------------------------------------------------- 1 | remote-repo: hackage.haskell.org:http://hackage.haskell.org/packages/archive 2 | remote-repo-cache: 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/Util/Args.hs: -------------------------------------------------------------------------------- 1 | module Util.Args ( parseArgs 2 | , GetOpt(..) 3 | , Switch(..) 4 | , DynOpt(..) 5 | , StaticOpt(..) 6 | , ArgArrow 7 | , liftIO 8 | ) where 9 | 10 | import Util.Args.Args (parseArgs) 11 | import Util.Args.GetOpt 12 | import Util.Args.ArgArrow 13 | -------------------------------------------------------------------------------- /src/HsenvMonadUtils.hs: -------------------------------------------------------------------------------- 1 | module HsenvMonadUtils (runInTmpDir) where 2 | 3 | import System.Directory 4 | import Util.IO 5 | import HsenvMonad 6 | 7 | runInTmpDir :: Hsenv a -> Hsenv a 8 | runInTmpDir m = do 9 | tmp <- liftIO getTemporaryDirectory 10 | tmpDir <- liftIO $ createTemporaryDirectory tmp "hsenv" 11 | oldCwd <- liftIO getCurrentDirectory 12 | liftIO $ setCurrentDirectory tmpDir 13 | let cleanup = do 14 | liftIO $ setCurrentDirectory oldCwd 15 | liftIO $ removeDirectoryRecursive tmpDir 16 | m `finally` cleanup 17 | -------------------------------------------------------------------------------- /skeletons/ghc: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | 3 | PATH_ELEMS="$(echo ${PATH} | tr -s ':' '\n')" 4 | 5 | ORIG_GHC_BINARY="" 6 | 7 | for PATH_ELEM in ${PATH_ELEMS}; do 8 | GHC_CANDIDATE="${PATH_ELEM}/ghc" 9 | if command -v "${GHC_CANDIDATE}" > /dev/null 2> /dev/null; then 10 | if [ "${0}" != "${GHC_CANDIDATE}" ]; then 11 | if [ -z "${ORIG_GHC_BINARY}" ]; then 12 | ORIG_GHC_BINARY="${GHC_CANDIDATE}" 13 | fi 14 | fi 15 | fi 16 | done 17 | 18 | if [ -z "${ORIG_GHC_BINARY}" ]; then 19 | echo "ghc wrapper: Couldn't find real ghc program" 20 | exit 1 21 | fi 22 | 23 | exec "$ORIG_GHC_BINARY" ${PACKAGE_DB_FOR_GHC} "$@" 24 | -------------------------------------------------------------------------------- /skeletons/ghci: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | 3 | PATH_ELEMS="$(echo ${PATH} | tr -s ':' '\n')" 4 | 5 | ORIG_GHCI_BINARY="" 6 | 7 | for PATH_ELEM in ${PATH_ELEMS}; do 8 | GHCI_CANDIDATE="${PATH_ELEM}/ghci" 9 | if command -v "${GHCI_CANDIDATE}" > /dev/null 2> /dev/null; then 10 | if [ "${0}" != "${GHCI_CANDIDATE}" ]; then 11 | if [ -z "${ORIG_GHCI_BINARY}" ]; then 12 | ORIG_GHCI_BINARY="${GHCI_CANDIDATE}" 13 | fi 14 | fi 15 | fi 16 | done 17 | 18 | if [ -z "${ORIG_GHCI_BINARY}" ]; then 19 | echo "ghci wrapper: Couldn't find real ghci program" 20 | exit 1 21 | fi 22 | 23 | exec "$ORIG_GHCI_BINARY" ${PACKAGE_DB_FOR_GHC} "$@" 24 | -------------------------------------------------------------------------------- /skeletons/runghc: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | 3 | PATH_ELEMS="$(echo ${PATH} | tr -s ':' '\n')" 4 | 5 | ORIG_RUNGHC_BINARY="" 6 | 7 | for PATH_ELEM in ${PATH_ELEMS}; do 8 | RUNGHC_CANDIDATE="${PATH_ELEM}/runghc" 9 | if command -v "${RUNGHC_CANDIDATE}" > /dev/null 2> /dev/null; then 10 | if [ "${0}" != "${RUNGHC_CANDIDATE}" ]; then 11 | if [ -z "${ORIG_RUNGHC_BINARY}" ]; then 12 | ORIG_RUNGHC_BINARY="${RUNGHC_CANDIDATE}" 13 | fi 14 | fi 15 | fi 16 | done 17 | 18 | if [ -z "${ORIG_RUNGHC_BINARY}" ]; then 19 | echo "runghc wrapper: Couldn't find real runghc program" 20 | exit 1 21 | fi 22 | 23 | exec "$ORIG_RUNGHC_BINARY" ${PACKAGE_DB_FOR_GHC} "$@" 24 | -------------------------------------------------------------------------------- /skeletons/ghc-mod: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | 3 | PATH_ELEMS="$(echo ${PATH} | tr -s ':' '\n')" 4 | 5 | ORIG_GHC_MOD_BINARY="" 6 | 7 | for PATH_ELEM in ${PATH_ELEMS}; do 8 | GHC_MOD_CANDIDATE="${PATH_ELEM}/ghc-mod" 9 | if command -v "${GHC_MOD_CANDIDATE}" > /dev/null 2> /dev/null; then 10 | if [ "${0}" != "${GHC_MOD_CANDIDATE}" ]; then 11 | if [ -z "${ORIG_GHC_MOD_BINARY}" ]; then 12 | ORIG_GHC_MOD_BINARY="${GHC_MOD_CANDIDATE}" 13 | fi 14 | fi 15 | fi 16 | done 17 | 18 | if [ -z "${ORIG_GHC_MOD_BINARY}" ]; then 19 | echo "ghc-mod wrapper: Couldn't find real ghc-mod program" 20 | exit 1 21 | fi 22 | 23 | exec "$ORIG_GHC_MOD_BINARY" ${PACKAGE_DB_FOR_GHC_MOD} "$@" 24 | -------------------------------------------------------------------------------- /skeletons/ghc-pkg: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | 3 | PATH_ELEMS="$(echo ${PATH} | tr -s ':' '\n')" 4 | 5 | ORIG_GHC_PKG_BINARY="" 6 | 7 | for PATH_ELEM in ${PATH_ELEMS}; do 8 | GHC_PKG_CANDIDATE="${PATH_ELEM}/ghc-pkg" 9 | if command -v "${GHC_PKG_CANDIDATE}" > /dev/null 2> /dev/null; then 10 | if [ "${0}" != "${GHC_PKG_CANDIDATE}" ]; then 11 | if [ -z "${ORIG_GHC_PKG_BINARY}" ]; then 12 | ORIG_GHC_PKG_BINARY="${GHC_PKG_CANDIDATE}" 13 | fi 14 | fi 15 | fi 16 | done 17 | 18 | if [ -z "${ORIG_GHC_PKG_BINARY}" ]; then 19 | echo "ghc-pkg wrapper: Couldn't find real ghc-pkg program" 20 | exit 1 21 | fi 22 | 23 | exec "$ORIG_GHC_PKG_BINARY" ${PACKAGE_DB_FOR_GHC_PKG} "$@" 24 | -------------------------------------------------------------------------------- /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/WordWrap.hs: -------------------------------------------------------------------------------- 1 | module Util.WordWrap (wordWrap) where 2 | 3 | import Data.Char (isSpace) 4 | 5 | trim :: String -> String 6 | trim = trimAndReverse . trimAndReverse 7 | where trimAndReverse = reverse . dropWhile isSpace 8 | 9 | reverseBreak :: (a -> Bool) -> [a] -> ([a], [a]) 10 | reverseBreak f xs = (reverse before, reverse after) 11 | where (after, before) = break f $ reverse xs 12 | 13 | wordWrap :: Int -> String -> [String] 14 | wordWrap maxLen line = 15 | case break (== '\n') chunk of 16 | (beginning, '\n':rest) -> beginning : wordWrap maxLen (rest ++ chunks) 17 | _ -> wordWrap' maxLen line 18 | where (chunk, chunks) = splitAt maxLen line 19 | 20 | wordWrap' :: Int -> String -> [String] 21 | wordWrap' maxLen line 22 | | length line <= maxLen = [trim line] 23 | | any isSpace beforeMax = trim beforeSpace : wordWrap maxLen (afterSpace ++ afterMax) 24 | | otherwise = firstBigWord : wordWrap maxLen rest 25 | where (beforeMax, afterMax) = splitAt maxLen line 26 | (beforeSpace, afterSpace) = reverseBreak isSpace beforeMax 27 | (firstBigWord, rest) = break isSpace line 28 | -------------------------------------------------------------------------------- /src/Util/Args/ArgDescr.hs: -------------------------------------------------------------------------------- 1 | module Util.Args.ArgDescr ( DefaultValue(..) 2 | , ArgDescr(..) 3 | , KnownArgs 4 | ) where 5 | 6 | -- default value for cli option 7 | data DefaultValue = ConstValue String -- explicit default value 8 | | DynValue String -- human readable description of a process 9 | -- that will provide default value 10 | 11 | -- cli option description 12 | data ArgDescr = 13 | -- switch 14 | SwitchDescr { argName :: String -- switch name (e.g. 'verbose' for --verbose) 15 | , helpMsg :: String -- human readable description of this switch 16 | , shortOpt :: Maybe Char -- optional short version for this switch 17 | -- (e.g. 'v' for '-v' 18 | -- as a shortcut for '--verbose') 19 | } 20 | -- option with a value 21 | | ValArg { argName :: String -- option name (e.g. 'key' for '--key=value') 22 | , valTemplate :: String -- help template for value (e.g. 'PATH' for --binary=PATH) 23 | , defaultValue :: DefaultValue -- default value 24 | , helpMsg :: String -- human readable description of this switch 25 | } 26 | 27 | type KnownArgs = [ArgDescr] 28 | -------------------------------------------------------------------------------- /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 | 18 | simpleWrappers :: [(String, String)] 19 | simpleWrappers = [ ghcWrapperSkel 20 | , ghciWrapperSkel 21 | , ghcPkgWrapperSkel 22 | , ghcModWrapperSkel 23 | , runghcWrapperSkel 24 | ] 25 | 26 | ghcWrapperSkel :: (String, String) 27 | ghcWrapperSkel = ("ghc", unpack $(embedFile $ "skeletons" "ghc")) 28 | 29 | ghciWrapperSkel :: (String, String) 30 | ghciWrapperSkel = ("ghci", unpack $(embedFile $ "skeletons" "ghci")) 31 | 32 | ghcPkgWrapperSkel :: (String, String) 33 | ghcPkgWrapperSkel = ("ghc-pkg", unpack $(embedFile $ "skeletons" "ghc-pkg")) 34 | 35 | ghcModWrapperSkel :: (String, String) 36 | ghcModWrapperSkel = ("ghc-mod", unpack $(embedFile $ "skeletons" "ghc-mod")) 37 | 38 | runghcWrapperSkel :: (String, String) 39 | runghcWrapperSkel = ("runghc", unpack $(embedFile $ "skeletons" "runghc")) 40 | -------------------------------------------------------------------------------- /src/Util/StaticArrowT.hs: -------------------------------------------------------------------------------- 1 | module Util.StaticArrowT ( StaticArrowT(..) 2 | , addStatic 3 | , getStatic 4 | ) where 5 | 6 | import Data.Monoid (Monoid(..)) 7 | import Control.Arrow (Arrow(..), ArrowChoice(..)) 8 | import qualified Control.Category as C 9 | 10 | -- arrow transformer, that adds static information 11 | -- to underlying computation 12 | data StaticArrowT m arr a b = StaticArrowT m (arr a b) 13 | 14 | instance (C.Category arr, Monoid m) => C.Category (StaticArrowT m arr) where 15 | id = StaticArrowT mempty C.id 16 | StaticArrowT m2 arr2 . StaticArrowT m1 arr1 = 17 | StaticArrowT (m2 `mappend` m1) $ arr2 C.. arr1 18 | 19 | instance (Arrow arr, Monoid m) => Arrow (StaticArrowT m arr) where 20 | arr f = StaticArrowT mempty $ arr f 21 | first (StaticArrowT m arrow) = StaticArrowT m $ first arrow 22 | 23 | instance (ArrowChoice arr, Monoid m) => ArrowChoice (StaticArrowT m arr) where 24 | left (StaticArrowT m arrow) = StaticArrowT m $ left arrow 25 | 26 | -- simplest computation with specified static information 27 | addStatic :: (Monoid m, Arrow arr) => m -> StaticArrowT m arr a a 28 | addStatic m = StaticArrowT m C.id 29 | 30 | -- returns static information from the whole computation 31 | -- (without running it) 32 | getStatic :: (Monoid m, Arrow arr) => StaticArrowT m arr a b -> m 33 | getStatic (StaticArrowT m _) = m 34 | -------------------------------------------------------------------------------- /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 | -------------------------------------------------------------------------------- /src/Util/Args/ArgArrow.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 2 | module Util.Args.ArgArrow ( ArgArrow 3 | , runArgArrow 4 | , liftIO 5 | , addKnownArg 6 | , askArgs 7 | , getKnownArgs 8 | ) where 9 | 10 | import Util.StaticArrowT (StaticArrowT(..), addStatic, getStatic) 11 | import Util.Args.RawArgs (Args) 12 | import Util.Args.ArgDescr (KnownArgs) 13 | import Data.Monoid (mempty) 14 | import Control.Monad.Reader (ReaderT(..), ask) 15 | import qualified Control.Monad.Reader as Reader (liftIO) 16 | import Control.Arrow (Kleisli(..), Arrow, ArrowChoice) 17 | import Control.Category (Category) 18 | 19 | -- cli options parsing arrow, that exports statically all known args, and their info 20 | newtype ArgArrow a b = ArgArrow (StaticArrowT KnownArgs (Kleisli (ReaderT Args IO)) a b) 21 | deriving (Category, Arrow, ArrowChoice) 22 | 23 | runArgArrow :: ArgArrow () a -> Args -> IO a 24 | runArgArrow (ArgArrow (StaticArrowT _ m)) = runReaderT $ runKleisli m () 25 | 26 | liftIO :: (a -> IO b) -> ArgArrow a b 27 | liftIO m = ArgArrow $ StaticArrowT mempty $ Kleisli (Reader.liftIO . m) 28 | 29 | -- record statically new known argument 30 | addKnownArg :: KnownArgs -> ArgArrow () () 31 | addKnownArg = ArgArrow . addStatic 32 | 33 | -- returns raw parsed args 34 | askArgs :: ArgArrow () Args 35 | askArgs = ArgArrow $ StaticArrowT mempty $ Kleisli $ const ask 36 | 37 | -- returns statically known (by this computation) cli args 38 | getKnownArgs :: ArgArrow a b -> KnownArgs 39 | getKnownArgs (ArgArrow arrow) = getStatic arrow 40 | -------------------------------------------------------------------------------- /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 | CABAL_BUILDDIR_ARG="" 26 | 27 | if [ -z "" ]; then 28 | CABAL_BUILDIR="dist" 29 | else 30 | CABAL_BUILDIR="dist_" 31 | fi 32 | 33 | CABAL_BUILDABLE_COMMANDS="build clean configure copy haddock hscolour install register sdist test upgrade" 34 | 35 | CABAL_COMMAND="$(echo ${@} | tr -s ' ' '\n' | grep -E '[a-z]' | grep -Ev '^-' | head -n 1)" 36 | 37 | for CABAL_BUILDABLE_COMMAND in ${CABAL_BUILDABLE_COMMANDS}; do 38 | if [ "${CABAL_BUILDABLE_COMMAND}" = "${CABAL_COMMAND}" ]; then 39 | CABAL_BUILDDIR_ARG="--builddir=${CABAL_BUILDIR}" 40 | fi 41 | done 42 | 43 | CABAL_CONFIGURE_COMMANDS="configure install upgrade" 44 | 45 | for CABAL_CONFIGURE_COMMAND in ${CABAL_CONFIGURE_COMMANDS}; do 46 | if [ "${CABAL_CONFIGURE_COMMAND}" = "${CABAL_COMMAND}" ]; then 47 | CABAL_BUILDDIR_ARG="${CABAL_BUILDDIR_ARG} ${PACKAGE_DB_FOR_CABAL}" 48 | fi 49 | done 50 | 51 | exec "${ORIG_CABAL_BINARY}" \ 52 | --config-file="${CABAL_CONFIG}" \ 53 | ${CABAL_BUILDDIR_ARG} "${@}" 54 | -------------------------------------------------------------------------------- /src/hsenv.hs: -------------------------------------------------------------------------------- 1 | import Control.Monad (when) 2 | import System.IO (stderr, hPutStrLn) 3 | import System.Exit (exitFailure) 4 | import System.FilePath (()) 5 | 6 | import Types 7 | import HsenvMonad 8 | import Actions 9 | import SanityCheck (sanityCheck) 10 | import Args (getArgs) 11 | import Paths (dotDirName, constructDotDirName) 12 | 13 | main :: IO () 14 | main = do 15 | options <- getArgs 16 | (result, messageLog) <- runHsenv realMain options 17 | case result of 18 | Left err -> do 19 | hPutStrLn stderr $ getExceptionMessage err 20 | hPutStrLn stderr "" 21 | hPutStrLn stderr "hsenv.log file contains detailed description of the process." 22 | let errorLog = unlines $ messageLog ++ ["", getExceptionMessage err] 23 | writeFile "hsenv.log" errorLog 24 | exitFailure 25 | Right () -> do 26 | let dotDir = constructDotDirName options 27 | writeFile (dotDir "hsenv.log") $ unlines messageLog 28 | 29 | realMain :: Hsenv () 30 | realMain = do 31 | initDotHsenvDir 32 | skipSanityCheckFlag <- asks skipSanityCheck 33 | if skipSanityCheckFlag then 34 | info "WARNING: sanity checks are disabled." 35 | else 36 | sanityCheck 37 | createDirStructure 38 | installGhc 39 | initGhcDb 40 | copyBaseSystem 41 | installCabalConfig 42 | installActivateScript 43 | installCabalWrapper 44 | installSimpleWrappers 45 | installProgSymlinks 46 | symlinkToSkeleton "runghc" "runhaskell" 47 | bootstrapCabalFlag <- asks cabalBootstrap 48 | when bootstrapCabalFlag bootstrapCabal 49 | cabalUpdate 50 | info "" 51 | dotDir <- dotDirName 52 | info $ "To activate the new environment use 'source " ++ dotDir ++ "/bin/activate'" 53 | -------------------------------------------------------------------------------- /src/Util/Args/RawArgs.hs: -------------------------------------------------------------------------------- 1 | module Util.Args.RawArgs ( Args(..) 2 | , parseArguments 3 | ) where 4 | 5 | import Data.Monoid (Monoid(..)) 6 | import Control.Monad (liftM) 7 | import Control.Monad.Instances () 8 | import Util.List (breakOn) 9 | 10 | {-# ANN Args "HLint: ignore Use String" #-} 11 | -- parsed command line options 12 | data Args = Args { shortSwitches :: [Char] -- list of enabled short switches 13 | , switches :: [String] -- list of enabled switches 14 | , valArgs :: [(String, String)] -- list of (key,value) cli opts 15 | , positionals :: [String] -- positional arguments 16 | } 17 | 18 | instance Monoid Args where 19 | mempty = Args [] [] [] [] 20 | Args xs1 ys1 zs1 us1 `mappend` Args xs2 ys2 zs2 us2 = 21 | Args (xs1 ++ xs2) (ys1 ++ ys2) (zs1 ++ zs2) (us1 ++ us2) 22 | 23 | -- parses a single word or returns an error 24 | parseArgument :: String -> Either String Args 25 | parseArgument ('-':'-':arg) = 26 | Right $ case breakOn '=' arg of 27 | Nothing -> mempty{switches = [arg]} 28 | Just (key, val) -> mempty{valArgs = [(key, val)]} 29 | parseArgument ['-', c] = Right mempty{shortSwitches = [c]} 30 | parseArgument param@('-':_) = Left $ "Invalid option: '" ++ param ++ "'" 31 | parseArgument arg = Right mempty{positionals = [arg]} 32 | 33 | -- parses many words or returns an error 34 | parseArguments :: [String] -> Either String Args 35 | parseArguments args = 36 | case breakOn "--" args of 37 | Nothing -> mconcat `liftM` mapM parseArgument args 38 | Just (args', rest) -> do 39 | parsedArgs <- mapM parseArgument args' 40 | return $ mconcat parsedArgs `mappend` mempty{positionals = rest} 41 | -------------------------------------------------------------------------------- /src/Util/Args/Usage.hs: -------------------------------------------------------------------------------- 1 | module Util.Args.Usage (usage) where 2 | 3 | import Util.Args.ArgDescr (ArgDescr(..), DefaultValue(..)) 4 | import Data.Function (on) 5 | import Util.WordWrap (wordWrap) 6 | import Data.List(sortBy) 7 | import Util.Args.ArgArrow (ArgArrow, getKnownArgs) 8 | import Util.String (padTo) 9 | import System.Environment (getProgName) 10 | 11 | -- pretty prints cli arg description for usage 12 | -- left column contains cli arg header (e.g. '--verbose', or '--binary=PATH') 13 | -- right column contains info messages for that argument 14 | -- returns list of lines 15 | showFlagDescr :: ArgDescr -> [String] 16 | showFlagDescr argDescr = zipWith makeLine lefts helpLines 17 | where lefts = argLine : repeat "" 18 | argLine = case argDescr of 19 | SwitchDescr name _ Nothing -> "--" ++ name 20 | SwitchDescr name _ (Just c) -> 21 | concat ["-", [c], " ", "--", name] 22 | ValArg name tmpl _ _ -> concat ["--", name, "=", tmpl] 23 | msgLines = wordWrap 60 $ case argDescr of 24 | SwitchDescr _ hlp _ -> hlp 25 | ValArg _ _ default' help -> 26 | concat [help, "\n", defaultsLine default'] 27 | helpLines = if length argLine < 18 then 28 | msgLines 29 | else 30 | "" : msgLines -- line with argument is too long 31 | -- make more room for it 32 | defaultsLine (ConstValue s) = concat ["(defaults to '", s, "')"] 33 | defaultsLine (DynValue s) = concat ["(defaults to ", s, ")"] 34 | makeLine infoLine descrLine = (infoLine `padTo` 20) ++ descrLine 35 | 36 | -- returns string with formatted cli arg usage help message 37 | -- argument descriptions are extracted from arg parsing computation 38 | -- adds simple header and appends provided footer 39 | usage :: ArgArrow a b -> String -> IO String 40 | usage arrow outro = do 41 | self <- getProgName 42 | let intro = "usage: " ++ self ++ " [FLAGS]" 43 | return $ unlines $ [intro, "", "Flags:"] ++ flagsDescr ++ [""] ++ [outro] 44 | where flagsDescr = concatMap showFlagDescr $ argDescrSort $ getKnownArgs arrow 45 | argDescrSort = sortBy (compare `on` argName) 46 | -------------------------------------------------------------------------------- /src/Util/Cabal.hs: -------------------------------------------------------------------------------- 1 | module Util.Cabal ( prettyVersion 2 | , prettyPkgInfo 3 | , parseVersion 4 | , parsePkgInfo 5 | , executableMatchesCabal 6 | ) where 7 | 8 | import Distribution.Version (Version(..), withinRange) 9 | import Distribution.Package (PackageName(..), Dependency(..), PackageIdentifier(..)) 10 | import Distribution.Compat.ReadP (readP_to_S) 11 | import Distribution.Text (parse, Text) 12 | import Distribution.PackageDescription (condTreeConstraints, condExecutables, GenericPackageDescription) 13 | 14 | import Data.Char (isSpace) 15 | import Data.List (isPrefixOf, intercalate) 16 | 17 | -- render Version to human and ghc-pkg readable string 18 | prettyVersion :: Version -> String 19 | prettyVersion (Version [] _) = "" 20 | prettyVersion (Version numbers _) = intercalate "." $ map show numbers 21 | 22 | -- render PackageIdentifier to human and ghc-pkg readable string 23 | prettyPkgInfo :: PackageIdentifier -> String 24 | prettyPkgInfo (PackageIdentifier (PackageName name) (Version [] _)) = name 25 | prettyPkgInfo (PackageIdentifier (PackageName name) version) = 26 | name ++ "-" ++ prettyVersion version 27 | 28 | parseVersion :: String -> Maybe Version 29 | parseVersion = parseCheck 30 | 31 | parseCheck :: Text a => String -> Maybe a 32 | parseCheck str = 33 | case [ x | (x,ys) <- readP_to_S parse str, all isSpace ys ] of 34 | [x] -> Just x 35 | _ -> Nothing 36 | 37 | parsePkgInfo :: String -> Maybe PackageIdentifier 38 | parsePkgInfo str | "builtin_" `isPrefixOf` str = 39 | let name = drop (length "builtin_") str -- ghc-pkg doesn't like builtin_ prefix 40 | in Just $ PackageIdentifier (PackageName name) $ Version [] [] 41 | | otherwise = parseCheck str 42 | 43 | executableMatchesCabal :: String -> Version -> GenericPackageDescription -> Bool 44 | executableMatchesCabal executable cabalVersion pkgDescr = 45 | case lookup executable $ condExecutables pkgDescr of 46 | Nothing -> False 47 | Just depGraph -> 48 | let deps = condTreeConstraints depGraph 49 | isCabalDep (Dependency (PackageName name) _) = name == "Cabal" 50 | cabalDeps = filter isCabalDep deps 51 | matchesDep (Dependency _ versionRange) = cabalVersion `withinRange` versionRange 52 | in all matchesDep cabalDeps 53 | -------------------------------------------------------------------------------- /src/Types.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 2 | module Types ( GhcSource(..) 3 | , Options(..) 4 | , HsenvState(..) 5 | , DirStructure(..) 6 | , HsenvException(..) 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 | | Url String -- Use GHC downloadable at URL 15 | | Release String -- Infer a URL and use GHC from there 16 | 17 | data Verbosity = Quiet 18 | | Verbose 19 | | VeryVerbose 20 | deriving (Eq, Ord) 21 | 22 | data Options = Options { verbosity :: Verbosity 23 | , skipSanityCheck :: Bool 24 | , hsEnvName :: Maybe String -- Virtual Haskell Environment name 25 | , envParentDir :: FilePath 26 | , ghcSource :: GhcSource 27 | , makeCmd :: String -- make substitute used for 'make install' of external GHC 28 | , noSharing :: Bool -- don't share ~/.cabal/packages 29 | , noPS1 :: Bool -- Don't modify shell prompt 30 | , cabalBootstrap :: Bool 31 | } 32 | 33 | data HsenvState = HsenvState { logDepth :: Integer -- used for indentation of logging messages 34 | } 35 | 36 | newtype HsenvException = HsenvException { getExceptionMessage :: String } 37 | deriving Error 38 | 39 | -- Only absolute paths! 40 | data DirStructure = DirStructure { hsEnv :: FilePath -- dir containing .hsenv_ENVNAME dir 41 | -- (usually dir with cabal project) 42 | , hsEnvDir :: FilePath -- .hsenv_ENVNAME dir 43 | , ghcPackagePath :: FilePath -- file (=ghc-6.12) containing private GHC pkg db 44 | , cabalDir :: FilePath -- directory with private cabal dir 45 | , cabalBinDir :: FilePath -- cabal's bin/ dir (used in $PATH) 46 | , hsEnvBinDir :: FilePath -- dir with haskell tools wrappers and activate script 47 | , ghcDir :: FilePath -- directory with private copy of external GHC (only used when using GHC from tarball) 48 | , ghcBinDir :: FilePath -- ghc's bin/ dir (with ghc[i|-pkg]) (only used when using GHC from tarball) 49 | } 50 | -------------------------------------------------------------------------------- /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 HsenvMonad 9 | import Paths (hseDirStructure, dotDirName) 10 | 11 | -- check if any virtual env is already active 12 | checkHSE :: Hsenv () 13 | checkHSE = do 14 | hsEnvVar <- liftIO $ getEnvVar "HSENV" 15 | case hsEnvVar of 16 | Nothing -> return () 17 | Just path -> do 18 | hsEnvNameVar <- liftIO $ getEnvVar "HSENV_NAME" 19 | case hsEnvNameVar of 20 | Nothing -> do 21 | debug $ "warning: HSENV environment variable is defined" ++ ", but no HSENV_NAME environment variable defined." 22 | throwError $ HsenvException $ "There is already active Virtual Haskell Environment (at " ++ path ++ ")." 23 | Just name -> 24 | throwError $ HsenvException $ "There is already active " ++ name ++ " Virtual Haskell Environment (at " ++ path ++ ")." 25 | 26 | checkHsenvAlreadyExists :: Hsenv () 27 | checkHsenvAlreadyExists = do 28 | dirStructure <- hseDirStructure 29 | flag <- liftIO $ doesDirectoryExist $ hsEnvDir dirStructure 30 | dotDir <- dotDirName 31 | when flag $ throwError $ HsenvException $ "There is already " ++ dotDir ++ " directory at " ++ hsEnv dirStructure 32 | 33 | -- check if cabal binary exist on PATH 34 | checkCabalInstall :: Hsenv () 35 | checkCabalInstall = do 36 | cabalInstallPath <- liftIO $ which Nothing "cabal" 37 | case cabalInstallPath of 38 | Just _ -> return () 39 | Nothing -> throwError $ HsenvException $ "Couldn't find cabal binary (from cabal-install package) in your $PATH." ++ 40 | "You could try using '--bootstrap-cabal' switch." 41 | 42 | -- check if GHC tools (ghc, ghc-pkg) exist on PATH 43 | -- skip the check if using GHC from a tarball 44 | checkGhc :: Hsenv () 45 | checkGhc = do 46 | ghcSrc <- asks ghcSource 47 | case ghcSrc of 48 | System -> do 49 | ghcPath <- liftIO $ which Nothing "ghc" 50 | case ghcPath of 51 | Just _ -> return () 52 | Nothing -> throwError $ HsenvException "Couldn't find ghc binary in your $PATH." 53 | ghc_pkgPath <- liftIO $ which Nothing "ghc-pkg" 54 | case ghc_pkgPath of 55 | Just _ -> return () 56 | Nothing -> throwError $ HsenvException "Couldn't find ghc-pkg binary in your $PATH." 57 | _ -> return () 58 | 59 | -- check if everything is sane 60 | sanityCheck :: Hsenv () 61 | sanityCheck = do 62 | checkHSE 63 | checkHsenvAlreadyExists 64 | bootstrappingCabal <- asks cabalBootstrap 65 | when (not bootstrappingCabal) checkCabalInstall 66 | checkGhc 67 | -------------------------------------------------------------------------------- /src/HsenvMonad.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE GeneralizedNewtypeDeriving, ScopedTypeVariables #-} 2 | module HsenvMonad ( Hsenv 3 | , runHsenv 4 | , indentMessages 5 | , debug 6 | , info 7 | , trace 8 | , warning 9 | , finally 10 | , throwError 11 | , catchError 12 | , ask 13 | , asks 14 | , gets 15 | , tell 16 | , modify 17 | , liftIO 18 | , action 19 | ) where 20 | 21 | import Types 22 | 23 | import Control.Exception as Exception (IOException, catch) 24 | import Control.Monad.Trans (MonadIO, liftIO) 25 | import Control.Monad.Reader (ReaderT, MonadReader, runReaderT, asks, ask) 26 | import Control.Monad.Writer (WriterT, MonadWriter, runWriterT, tell) 27 | import Control.Monad.State (StateT, MonadState, evalStateT, modify, gets) 28 | import Control.Monad.Error (ErrorT, MonadError, runErrorT, throwError, catchError) 29 | import Control.Monad (when) 30 | import System.IO (stderr, hPutStrLn) 31 | 32 | import Prelude hiding (log) 33 | 34 | newtype Hsenv a = Hsenv (StateT HsenvState (ReaderT Options (ErrorT HsenvException (WriterT [String] IO))) a) 35 | deriving (Functor, Monad, MonadReader Options, MonadState HsenvState, MonadError HsenvException, MonadWriter [String]) 36 | 37 | instance MonadIO Hsenv where 38 | liftIO m = Hsenv $ do 39 | x <- liftIO $ (Right `fmap` m) `Exception.catch` \(e :: IOException) -> return $ Left e 40 | case x of 41 | Left e -> throwError $ HsenvException $ "IO error: " ++ show e 42 | Right y -> return y 43 | 44 | runHsenv :: Hsenv a -> Options -> IO (Either HsenvException a, [String]) 45 | runHsenv (Hsenv m) = runWriterT . runErrorT . runReaderT (evalStateT m (HsenvState 0)) 46 | 47 | finally :: Hsenv a -> Hsenv b -> Hsenv a 48 | finally m sequel = do 49 | result <- (Right `fmap` m) `catchError` (return . Left) 50 | _ <- sequel 51 | case result of 52 | Left e -> throwError e 53 | Right x -> return x 54 | 55 | indentMessages :: Hsenv a -> Hsenv a 56 | indentMessages m = do 57 | modify (\s -> s{logDepth = logDepth s + 2}) 58 | result <- m 59 | modify (\s -> s{logDepth = logDepth s - 2}) 60 | return result 61 | 62 | -- add message to private log and return adjusted message (with log depth) 63 | -- that can be printed somewhere else 64 | privateLog :: String -> Hsenv String 65 | privateLog str = do 66 | depth <- gets logDepth 67 | let text = replicate (fromInteger depth) ' ' ++ str 68 | tell [text] 69 | return text 70 | 71 | log :: Verbosity -> String -> Hsenv () 72 | log minLevel str = do 73 | text <- privateLog str 74 | flag <- asks verbosity 75 | when (flag >= minLevel) $ 76 | liftIO $ putStrLn text 77 | 78 | debug :: String -> Hsenv () 79 | debug = log Verbose 80 | 81 | info :: String -> Hsenv () 82 | info = log Quiet 83 | 84 | trace :: String -> Hsenv () 85 | trace = log VeryVerbose 86 | 87 | warning :: String -> Hsenv () 88 | warning str = do 89 | text <- privateLog str 90 | liftIO $ hPutStrLn stderr text 91 | 92 | action :: String -> Hsenv a -> Hsenv a 93 | action descr m = info descr >> indentMessages m 94 | -------------------------------------------------------------------------------- /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 as Exception (catch, 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 `Exception.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 :: Maybe String -> String -> IO (Maybe FilePath) 67 | which pathVar name = do 68 | path <- case pathVar of 69 | Nothing -> getEnvVar "PATH" 70 | Just path -> return $ Just path 71 | case path of 72 | Nothing -> return Nothing 73 | Just path' -> do 74 | let pathElems = splitOn ":" path' 75 | aux x@(Just _) _ = return x 76 | aux Nothing pathDir = do 77 | let programPath = pathDir name 78 | flag <- doesFileExist programPath 79 | if flag then 80 | return $ Just programPath 81 | else 82 | return Nothing 83 | foldM aux Nothing pathElems 84 | -------------------------------------------------------------------------------- /src/Paths.hs: -------------------------------------------------------------------------------- 1 | module Paths ( hseDirStructure 2 | , cabalConfigLocation 3 | , dotDirName 4 | , constructDotDirName 5 | , insidePathVar 6 | , cachedCabalInstallPath 7 | ) where 8 | 9 | import Data.List (intercalate) 10 | import Distribution.Version (Version) 11 | import System.Directory (getAppUserDataDirectory) 12 | import System.FilePath (()) 13 | 14 | import Util.IO (getEnvVar) 15 | import Util.Cabal (prettyVersion) 16 | import Types 17 | import HsenvMonad 18 | 19 | -- returns record containing paths to all important directories 20 | -- inside virtual environment dir structure 21 | hseDirStructure :: Hsenv DirStructure 22 | hseDirStructure = do 23 | parentDir <- asks envParentDir 24 | dirName <- dotDirName 25 | let hsEnvLocation = parentDir 26 | hsEnvDirLocation = hsEnvLocation dirName 27 | cabalDirLocation = hsEnvDirLocation "cabal" 28 | ghcDirLocation = hsEnvDirLocation "ghc" 29 | return DirStructure { hsEnv = hsEnvLocation 30 | , hsEnvDir = hsEnvDirLocation 31 | , ghcPackagePath = hsEnvDirLocation "ghc_pkg_db" 32 | , cabalDir = cabalDirLocation 33 | , cabalBinDir = cabalDirLocation "bin" 34 | , hsEnvBinDir = hsEnvDirLocation "bin" 35 | , ghcDir = ghcDirLocation 36 | , ghcBinDir = ghcDirLocation "bin" 37 | } 38 | 39 | constructDotDirName :: Options -> String 40 | constructDotDirName opts = maybe ".hsenv" (".hsenv_" ++) (hsEnvName opts) 41 | 42 | -- directory name of hsEnvDir 43 | dotDirName :: Hsenv String 44 | dotDirName = do 45 | opts <- ask 46 | return $ constructDotDirName opts 47 | 48 | -- returns location of cabal's config file inside virtual environment dir structure 49 | cabalConfigLocation :: Hsenv FilePath 50 | cabalConfigLocation = do 51 | dirStructure <- hseDirStructure 52 | return $ cabalDir dirStructure "config" 53 | 54 | -- returns value of $PATH env variable to be used inside virtual environment 55 | insidePathVar :: Hsenv String 56 | insidePathVar = do 57 | oldPathVar <- liftIO $ getEnvVar "PATH" 58 | let oldPathVarSuffix = case oldPathVar of 59 | Nothing -> "" 60 | Just x -> ':' : x 61 | dirStructure <- hseDirStructure 62 | ghc <- asks ghcSource 63 | let extraPathElems = case ghc of 64 | System -> [cabalBinDir dirStructure] 65 | _ -> [cabalBinDir dirStructure, ghcBinDir dirStructure] 66 | return $ intercalate ":" extraPathElems ++ oldPathVarSuffix 67 | 68 | -- returns path to ~/.hsenv dir 69 | userHsenvDir :: Hsenv FilePath 70 | userHsenvDir = liftIO $ getAppUserDataDirectory "hsenv" 71 | 72 | -- returns path to ~/.hsenv/cache directory 73 | userCacheDir :: Hsenv FilePath 74 | userCacheDir = do 75 | baseDir <- userHsenvDir 76 | return $ baseDir "cache" 77 | 78 | -- returns path to cached version of compiled binary for cabal-install 79 | -- (depends on Cabal library version), 80 | -- e.g. ~/.hsenv/cache/cabal-install/Cabal-0.14.0 81 | cachedCabalInstallPath :: Version -> Hsenv FilePath 82 | cachedCabalInstallPath cabalVersion = do 83 | cacheDir <- userCacheDir 84 | let cabInsCachePath = cacheDir "cabal-install" 85 | return $ cabInsCachePath "Cabal-" ++ prettyVersion cabalVersion 86 | -------------------------------------------------------------------------------- /src/Util/Args/Args.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE Arrows #-} 2 | module Util.Args.Args (parseArgs) where 3 | 4 | import Util.Args.ArgDescr (ArgDescr(..), KnownArgs) 5 | import Util.Args.ArgArrow (ArgArrow, runArgArrow, askArgs, getKnownArgs, addKnownArg) 6 | import Util.Args.RawArgs (Args(..), parseArguments) 7 | import Control.Arrow ((>>>), returnA, arr) 8 | import System.Environment (getArgs) 9 | import System.IO (stderr, hPutStrLn) 10 | import System.Exit (exitFailure, exitSuccess) 11 | import Data.Maybe (catMaybes) 12 | import Util.Args.Usage (usage) 13 | 14 | -- cli arg parsing result 15 | data ArgParseResult a = Usage 16 | | Help 17 | | Error String 18 | | Version 19 | | OK a 20 | 21 | -- wraps a cli arg parsing computation to add few standard 22 | -- arguments: --help (and -h) and --version 23 | -- and allows to distinguish them in the result 24 | helperArgArrow :: ArgArrow a b -> ArgArrow a (ArgParseResult b) 25 | helperArgArrow arrow = proc x -> do 26 | addKnownArg knargs -< () 27 | args <- askArgs -< () 28 | if "help" `elem` switches args || 'h' `elem` shortSwitches args then 29 | returnA -< Help 30 | else if "usage" `elem` switches args then 31 | returnA -< Usage 32 | else if "version" `elem` switches args then 33 | returnA -< Version 34 | else 35 | arrow >>> arr OK -< x 36 | where knargs = [versionOpt, helpOpt] 37 | helpOpt = SwitchDescr "help" "Show this help message" (Just 'h') 38 | versionOpt = SwitchDescr "version" "Show version string" Nothing 39 | 40 | -- prints a msg to stderr and exits program with return value 1 41 | failWith :: String -> IO a 42 | failWith s = hPutStrLn stderr s >> exitFailure 43 | 44 | -- validates provided cli arguments against known argument descriptions 45 | -- handles unknown arguments, and currently forbids positional arguments 46 | validateArguments :: Args -> KnownArgs -> IO () 47 | validateArguments args knArgs 48 | | not $ null $ positionals args = failWith "Positional arguments are not allowed" 49 | | otherwise = 50 | either failWith return $ do 51 | mapM_ (validate "short switch" "-" knShortSwitches (:"")) $ shortSwitches args 52 | mapM_ (validate "switch" "--" knSwitches id) $ switches args 53 | mapM_ (validate "option" "--" knKeys id . fst) $ valArgs args 54 | where knShortSwitches = catMaybes $ flip map knArgs $ \x -> case x of 55 | SwitchDescr _ _ c -> c 56 | _ -> Nothing 57 | knSwitches = catMaybes $ flip map knArgs $ \x -> case x of 58 | SwitchDescr name _ _ -> Just name 59 | _ -> Nothing 60 | knKeys = catMaybes $ flip map knArgs $ \x -> case x of 61 | ValArg name _ _ _ -> Just name 62 | _ -> Nothing 63 | validate xName prefix knownXs showX x = 64 | if x `elem` knownXs then 65 | Right () 66 | else 67 | Left $ "Unknown " ++ xName ++ " '" ++ prefix ++ showX x ++ "'" 68 | 69 | -- takes a cli arg parsing computation, version string and usage msg footer 70 | -- runs the computation on program cli arguments 71 | -- and returns the result. if arguments validation fails, 72 | -- prints usage message and exits with failure 73 | parseArgs :: ArgArrow () a -> String -> String -> IO a 74 | parseArgs arrgArr version outro = do 75 | args <- getArgs 76 | case parseArguments args of 77 | Left s -> failWith s 78 | Right parsedArgs -> do 79 | validateArguments parsedArgs $ getKnownArgs arrgArr' 80 | result <- runArgArrow arrgArr' parsedArgs 81 | case result of 82 | OK a -> return a 83 | Error s -> failWith s 84 | Version -> putStrLn version >> exitSuccess 85 | _ -> usage arrgArr' outro >>= putStr >> exitSuccess 86 | where arrgArr' = helperArgArrow arrgArr 87 | -------------------------------------------------------------------------------- /skeletons/activate: -------------------------------------------------------------------------------- 1 | if [ -n "${HSENV}" ]; then 2 | if [ "" = "${HSENV}" -a "" = "${HSENV_NAME}" ]; then 3 | echo "${HSENV_NAME} Virtual Haskell Environment is already active." 4 | else 5 | echo "There is already ${HSENV_NAME} Virtual Haskell Environment activated." 6 | echo "(at ${HSENV})" 7 | echo "Deactivate it first (using command 'deactivate_hsenv'), to activate" 8 | echo " environment." 9 | fi 10 | return 1 11 | fi 12 | 13 | # Source a user script. 14 | hsenv_bin() { 15 | if [ -f ~/.hsenv/bin/$1 ]; then 16 | . ~/.hsenv/bin/$1 17 | fi 18 | } 19 | 20 | export HSENV="" 21 | export HSENV_NAME="" 22 | 23 | echo "Activating ${HSENV_NAME} Virtual Haskell Environment (at ${HSENV})." 24 | echo "" 25 | echo "Use regular Haskell tools (ghc, ghci, ghc-pkg, cabal) to manage your Haskell environment." 26 | echo "" 27 | echo "To exit from this virtual environment, enter command 'deactivate_hsenv'." 28 | 29 | hsenv_bin pre-activate 30 | 31 | HSENV_PATH_BACKUP="$PATH" 32 | 33 | if ; then 34 | HSENV_PS1_BACKUP="$PS1" 35 | fi 36 | 37 | deactivate_hsenv() { 38 | echo "Deactivating ${HSENV_NAME} Virtual Haskell Environment (at ${HSENV})." 39 | echo "Restoring previous environment settings." 40 | 41 | hsenv_bin pre-deactivate 42 | 43 | export PATH="$HSENV_PATH_BACKUP" 44 | unset -v HSENV_PATH_BACKUP 45 | 46 | if ; then 47 | PS1="$HSENV_PS1_BACKUP" 48 | unset -v HSENV_PS1_BACKUP 49 | fi 50 | 51 | hsenv_bin post-deactivate 52 | 53 | unset -v PACKAGE_DB_FOR_CABAL 54 | unset -v PACKAGE_DB_FOR_GHC_PKG 55 | unset -v PACKAGE_DB_FOR_GHC 56 | unset -v PACKAGE_DB_FOR_GHC_MOD 57 | unset -v HSENV 58 | unset -v HSENV_NAME 59 | unset -v HASKELL_PACKAGE_SANDBOX 60 | unset -f deactivate_hsenv 61 | unset -f hsenv_bin 62 | 63 | if [ -n "$BASH" -o -n "$ZSH_VERSION" ]; then 64 | hash -r 65 | fi 66 | } 67 | 68 | PATH_PREPENDIX="$(cat /path_var_prependix)" 69 | export PATH="${PATH_PREPENDIX}:${PATH}" 70 | unset -v PATH_PREPENDIX 71 | 72 | unset -v PACKAGE_DB_FOR_GHC 73 | ghc --version > /dev/null 74 | if [ "$?" -ne 0 ]; then 75 | echo "Failed to get ghc version. Deactivating environment..." 76 | deactivate_hsenv 77 | exit 1 78 | fi 79 | 80 | # To compare version numbers as ints, split at dots, check them all. 81 | GHC_VERSION_OUTPUT="$(ghc --version)" 82 | GHC_VERSION_NUMBER="$(echo $GHC_VERSION_OUTPUT | sed 's/.* //' | tr '.' ' ')" 83 | 84 | item=1 85 | for check_num in 7 6 1 86 | do 87 | cur_num=$(echo $GHC_VERSION_NUMBER | awk "{ print \$$item; }") 88 | 89 | if [ "$cur_num" -lt "$check_num" ] 90 | then 91 | PKG_DB_OPT_SUFFIX="conf" 92 | break 93 | fi 94 | item=$(expr $item + 1) 95 | done 96 | 97 | # If it's still unset, we're >= 7.6.1 98 | if [ -z "$PKG_DB_OPT_SUFFIX" ] 99 | then 100 | PKG_DB_OPT_SUFFIX="db" 101 | fi 102 | 103 | export HASKELL_PACKAGE_SANDBOX="`</ghc_package_path_var`" 104 | 105 | GHC_PACKAGE_PATH_REPLACEMENT="$(cat /ghc_package_path_var | sed -e 's/^/:/' -e 's/::*/:/g' -e 's/:\s*$//')" 106 | 107 | replace_pkg () { 108 | replacement=$1 109 | 110 | echo "$GHC_PACKAGE_PATH_REPLACEMENT" | sed -e "s/:/ $replacement/g" 111 | } 112 | 113 | export PACKAGE_DB_FOR_CABAL="$(replace_pkg '--package-db=')" 114 | export PACKAGE_DB_FOR_GHC_PKG=" --no-user-package-${PKG_DB_OPT_SUFFIX} $(replace_pkg --package-${PKG_DB_OPT_SUFFIX}=)" 115 | export PACKAGE_DB_FOR_GHC=" -no-user-package-${PKG_DB_OPT_SUFFIX} $(replace_pkg -package-${PKG_DB_OPT_SUFFIX}=)" 116 | export PACKAGE_DB_FOR_GHC_MOD=" -g -no-user-package-${PKG_DB_OPT_SUFFIX} $(replace_pkg '-g -package-'${PKG_DB_OPT_SUFFIX}=)" 117 | 118 | if ; then 119 | if [ -n "$HSENV_NAME" ]; then 120 | PS1="($HSENV_NAME)$PS1" 121 | else 122 | PS1="[hsenv]$PS1" 123 | fi 124 | fi 125 | 126 | unset -v GHC_VERSION_OUTPUT 127 | unset -v GHC_VERSION_NUMBER 128 | unset -v PKG_DB_OPT_SUFFIX 129 | unset -v GHC_PACKAGE_PATH_REPLACEMENT 130 | 131 | if [ -n "$BASH" -o -n "$ZSH_VERSION" ]; then 132 | hash -r 133 | fi 134 | 135 | hsenv_bin post-activate 136 | -------------------------------------------------------------------------------- /src/Util/Args/GetOpt.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE MultiParamTypeClasses 2 | , FunctionalDependencies 3 | , TypeSynonymInstances 4 | , FlexibleInstances 5 | , Arrows 6 | #-} 7 | module Util.Args.GetOpt ( GetOpt(..) 8 | , Switch(..) 9 | , DynOpt(..) 10 | , StaticOpt(..) 11 | ) where 12 | 13 | import Util.Args.ArgArrow (ArgArrow, askArgs, addKnownArg) 14 | import Util.Args.ArgDescr (DefaultValue(..), ArgDescr(..)) 15 | import Util.Args.RawArgs (Args(..)) 16 | import Data.Maybe (fromMaybe) 17 | import Control.Arrow (returnA) 18 | 19 | -- getOpt method takes a cli option description and returns at runtime value for that option. 20 | -- it also statically records information about such option (and uses it to generate usage) 21 | class GetOpt a b | a -> b where 22 | getOpt :: a -> ArgArrow () b 23 | 24 | -- description of a cli switch, getOpt-ing it will return True if it's present 25 | -- in cli args and False otherwise 26 | data Switch = 27 | Switch { switchName :: String -- switch long name (e.g. 'verbose' for '--verbose') 28 | , switchHelp :: String -- human readable switch description (used for usage msg) 29 | , switchShort :: Maybe Char -- optional short version of this switch 30 | -- (e.g. 'v' for '-v') 31 | } 32 | 33 | instance GetOpt Switch Bool where 34 | getOpt descr = proc () -> do 35 | addKnownArg [SwitchDescr (switchName descr) 36 | (switchHelp descr) 37 | (switchShort descr)] -< () 38 | args <- askArgs -< () 39 | let longSwitchStatus = switchName descr `elem` switches args 40 | switchStatus = case switchShort descr of 41 | Nothing -> longSwitchStatus 42 | Just c -> longSwitchStatus || c `elem` shortSwitches args 43 | returnA -< switchStatus 44 | 45 | -- description of a key,value cli argument, that if not present, 46 | -- defaults to a value returned by some dynamic process 47 | -- getOpt-ing it will return Just its value if it's present in cli args, 48 | -- otherwise Nothing 49 | data DynOpt = 50 | DynOpt { dynOptName :: String -- key name (e.g. 'foo' for '--foo=bar') 51 | , dynOptTemplate :: String -- help template for value 52 | -- (e.g. 'PATH' for --binary=PATH) 53 | , dynOptDescription :: String -- human readable description of a process 54 | -- that will provide default value 55 | -- (e.g. 'current directory') 56 | , dynOptHelp :: String -- human readable switch description 57 | -- (used for usage msg) 58 | } 59 | 60 | instance GetOpt DynOpt (Maybe String) where 61 | getOpt descr = proc () -> do 62 | addKnownArg [ValArg (dynOptName descr) 63 | (dynOptTemplate descr) 64 | (DynValue $ dynOptDescription descr) 65 | (dynOptHelp descr)] -< () 66 | args <- askArgs -< () 67 | returnA -< lookup (dynOptName descr) $ valArgs args 68 | 69 | -- description of a key,value cli argument, that if not present, 70 | -- defaults to an explicit value 71 | -- getOpt-ing it will return String with its value if it's present in cli args, 72 | -- otherwise default value is returned 73 | data StaticOpt = 74 | StaticOpt { staticOptName :: String -- key name (e.g. 'foo' for '--foo=bar') 75 | , staticOptTemplate :: String -- help template for value 76 | -- (e.g. 'PATH' for --binary=PATH) 77 | , staticOptDefault :: String -- default value for this argument 78 | , staticOptHelp :: String -- human readable switch description 79 | -- (used for usage msg) 80 | } 81 | 82 | instance GetOpt StaticOpt String where 83 | getOpt descr = proc () -> do 84 | addKnownArg [ValArg (staticOptName descr) 85 | (staticOptTemplate descr) 86 | (DynValue $ staticOptDefault descr) 87 | (staticOptHelp descr)] -< () 88 | args <- askArgs -< () 89 | returnA -< fromMaybe (staticOptDefault descr) 90 | $ lookup (staticOptName descr) 91 | $ valArgs args 92 | -------------------------------------------------------------------------------- /src/PackageManagement.hs: -------------------------------------------------------------------------------- 1 | module PackageManagement ( Transplantable(..) 2 | , parseVersion 3 | , parsePkgInfo 4 | , insideGhcPkg 5 | , outsideGhcPkg 6 | , getHighestVersion 7 | , GhcPkg 8 | ) where 9 | 10 | import Distribution.Package (PackageIdentifier(..), PackageName(..)) 11 | import Distribution.Version (Version(..)) 12 | import Control.Monad (unless) 13 | 14 | import Types 15 | import HsenvMonad 16 | import Process (outsideProcess, insideProcess) 17 | import Util.Cabal (prettyPkgInfo, prettyVersion) 18 | import qualified Util.Cabal (parseVersion, parsePkgInfo) 19 | 20 | type GhcPkg = [String] -> Maybe String -> Hsenv String 21 | 22 | outsideGhcPkg :: GhcPkg 23 | outsideGhcPkg = outsideProcess "ghc-pkg" 24 | 25 | insideGhcPkg :: GhcPkg 26 | insideGhcPkg = insideProcess "ghc-pkg" 27 | 28 | parseVersion :: String -> Hsenv Version 29 | parseVersion s = case Util.Cabal.parseVersion s of 30 | Nothing -> throwError $ HsenvException $ "Couldn't parse " ++ s ++ " as a package version" 31 | Just version -> return version 32 | 33 | parsePkgInfo :: String -> Hsenv PackageIdentifier 34 | parsePkgInfo s = case Util.Cabal.parsePkgInfo s of 35 | Nothing -> throwError $ HsenvException $ "Couldn't parse package identifier " ++ s 36 | Just pkgInfo -> return pkgInfo 37 | 38 | getDeps :: PackageIdentifier -> Hsenv [PackageIdentifier] 39 | getDeps pkgInfo = do 40 | let prettyPkg = prettyPkgInfo pkgInfo 41 | debug $ "Extracting dependencies of " ++ prettyPkg 42 | out <- indentMessages $ outsideGhcPkg ["field", prettyPkg, "depends"] Nothing 43 | -- example output: 44 | -- depends: ghc-prim-0.2.0.0-3fbcc20c802efcd7c82089ec77d92990 45 | -- integer-gmp-0.2.0.0-fa82a0df93dc30b4a7c5654dd7c68cf4 builtin_rts 46 | case words out of 47 | [] -> throwError $ HsenvException $ "Couldn't parse ghc-pkg output to find dependencies of " ++ prettyPkg 48 | _:depStrings -> do -- skip 'depends:' 49 | indentMessages $ trace $ "Found dependency strings: " ++ unwords depStrings 50 | mapM parsePkgInfo depStrings 51 | 52 | -- things that can be copied from system's GHC pkg database 53 | -- to GHC pkg database inside virtual environment 54 | class Transplantable a where 55 | transplantPackage :: a -> Hsenv () 56 | 57 | getHighestVersion :: PackageName -> GhcPkg -> Hsenv Version 58 | getHighestVersion (PackageName packageName) ghcPkg = do 59 | debug $ "Checking the highest installed version of package " ++ packageName 60 | out <- indentMessages $ ghcPkg ["field", packageName, "version"] Nothing 61 | -- example output: 62 | -- version: 1.1.4 63 | -- version: 1.2.0.3 64 | let extractVersionString :: String -> Hsenv String 65 | extractVersionString line = 66 | case words line of 67 | [_, x] -> return x 68 | _ -> throwError $ HsenvException $ "Couldn't extract version string from: " ++ line 69 | versionStrings <- mapM extractVersionString $ lines out 70 | indentMessages $ trace $ "Found version strings: " ++ unwords versionStrings 71 | versions <- mapM parseVersion versionStrings 72 | case versions of 73 | [] -> throwError $ HsenvException $ "No versions of package " ++ packageName ++ " found" 74 | (v:vs) -> do 75 | indentMessages $ debug $ "Found: " ++ unwords (map prettyVersion versions) 76 | return $ foldr max v vs 77 | 78 | -- choose the highest installed version of package with this name 79 | instance Transplantable PackageName where 80 | transplantPackage pkg@(PackageName packageName) = do 81 | debug $ "Copying package " ++ packageName ++ " to Virtual Haskell Environment." 82 | indentMessages $ do 83 | highestVersion <- getHighestVersion pkg outsideGhcPkg 84 | debug $ "Using version: " ++ prettyVersion highestVersion 85 | let pkgInfo = PackageIdentifier (PackageName packageName) highestVersion 86 | transplantPackage pkgInfo 87 | 88 | -- check if this package is already installed in Virtual Haskell Environment 89 | checkIfInstalled :: PackageIdentifier -> Hsenv Bool 90 | checkIfInstalled pkgInfo = do 91 | let package = prettyPkgInfo pkgInfo 92 | debug $ "Checking if " ++ package ++ " is already installed." 93 | (do 94 | _ <- indentMessages $ insideGhcPkg ["describe", package] Nothing 95 | indentMessages $ debug "It is." 96 | return True) `catchError` handler 97 | where handler _ = do 98 | debug "It's not." 99 | return False 100 | 101 | instance Transplantable PackageIdentifier where 102 | transplantPackage pkgInfo = do 103 | let prettyPkg = prettyPkgInfo pkgInfo 104 | debug $ "Copying package " ++ prettyPkg ++ " to Virtual Haskell Environment." 105 | indentMessages $ do 106 | flag <- checkIfInstalled pkgInfo 107 | unless flag $ do 108 | deps <- getDeps pkgInfo 109 | debug $ "Found: " ++ unwords (map prettyPkgInfo deps) 110 | mapM_ transplantPackage deps 111 | movePackage pkgInfo 112 | 113 | -- copy single package that already has all deps satisfied 114 | movePackage :: PackageIdentifier -> Hsenv () 115 | movePackage pkgInfo = do 116 | let prettyPkg = prettyPkgInfo pkgInfo 117 | debug $ "Moving package " ++ prettyPkg ++ " to Virtual Haskell Environment." 118 | out <- outsideGhcPkg ["describe", prettyPkg] Nothing 119 | _ <- insideGhcPkg ["register", "-"] (Just out) 120 | return () 121 | -------------------------------------------------------------------------------- /src/Args.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE Arrows, CPP #-} 2 | 3 | module Args (getArgs) where 4 | 5 | import Control.Arrow 6 | import Data.Char 7 | import Util.Args 8 | import System.Directory (getCurrentDirectory) 9 | import Types 10 | 11 | #ifdef cabal 12 | import Util.Cabal (prettyVersion) 13 | import Paths_hsenv (version) 14 | 15 | versionString :: String 16 | versionString = prettyVersion version 17 | #else 18 | versionString :: String 19 | versionString = "dev" 20 | #endif 21 | 22 | verbosityOpt, veryVerbosityOpt, skipSanityOpt, sharingOpt, noPS1Opt, bootstrapCabalOpt :: Switch 23 | 24 | verbosityOpt = Switch { switchName = "verbose" 25 | , switchHelp = "Print some debugging info" 26 | , switchShort = Just 'v' 27 | } 28 | 29 | veryVerbosityOpt = Switch { switchName = "very-verbose" 30 | , switchHelp = "Print some more debugging info" 31 | , switchShort = Nothing 32 | } 33 | 34 | skipSanityOpt = Switch { switchName = "skip-sanity-check" 35 | , switchHelp = "Skip all the sanity checks (use at your own risk)" 36 | , switchShort = Nothing 37 | } 38 | 39 | sharingOpt = Switch { switchName = "dont-share-cabal-cache" 40 | , switchHelp = "Don't share ~/.cabal/packages (hackage download cache)" 41 | , switchShort = Nothing 42 | } 43 | 44 | noPS1Opt = 45 | Switch { switchName = "no-ps1-indicator" 46 | , switchHelp = 47 | "Don't modify the shell prompt to indicate the current hsenv" 48 | , switchShort = Nothing 49 | } 50 | 51 | bootstrapCabalOpt = 52 | Switch { switchName = "bootstrap-cabal" 53 | , switchHelp = "Bootstrap cabal-install inside virtual environment" 54 | ++ "(Use this if you don't have cabal-install installed " 55 | ++ "or it's not on your $PATH)" 56 | , switchShort = Nothing 57 | } 58 | 59 | parentOpt, nameOpt, ghcOpt :: DynOpt 60 | 61 | parentOpt = DynOpt 62 | { dynOptName = "parent-dir" 63 | , dynOptTemplate = "PATH" 64 | , dynOptDescription = "current directory" 65 | , dynOptHelp = "Create Virtual Haskell Environment inside PATH" 66 | } 67 | 68 | nameOpt = DynOpt 69 | { dynOptName = "name" 70 | , dynOptTemplate = "NAME" 71 | , dynOptDescription = "current directory name" 72 | , dynOptHelp = "Use NAME as name of the Virtual Haskell Environment" 73 | } 74 | 75 | ghcOpt = DynOpt 76 | { dynOptName = "ghc" 77 | , dynOptTemplate = "VERSION|URL|FILE" 78 | , dynOptDescription = "system's copy of GHC" 79 | , dynOptHelp = 80 | "Use GHC from provided location -- a GHC version number, an HTTP or HTTPS URL or a path to a tarball (e.g. ghc-7.0.4-i386-unknown-linux.tar.bz2)" 81 | } 82 | 83 | makeOpt :: StaticOpt 84 | makeOpt = StaticOpt 85 | { staticOptName = "make-cmd" 86 | , staticOptTemplate = "CMD" 87 | , staticOptDefault = "make" 88 | , staticOptHelp = 89 | "Used as make substitute for installing GHC from tarball (e.g. gmake)" 90 | } 91 | 92 | argParser :: ArgArrow () Options 93 | argParser = proc () -> do 94 | verbosityFlag <- getOpt verbosityOpt -< () 95 | verbosityFlag2 <- getOpt veryVerbosityOpt -< () 96 | let verboseness = case (verbosityFlag, verbosityFlag2) of 97 | (_, True) -> VeryVerbose 98 | (True, False) -> Verbose 99 | (False, False) -> Quiet 100 | name <- getOpt nameOpt -< () 101 | parentFlag <- getOpt parentOpt -< () 102 | parent <- case parentFlag of 103 | Just parent' -> returnA -< parent' 104 | Nothing -> liftIO' getCurrentDirectory -< () 105 | ghcFlag <- getOpt ghcOpt -< () 106 | noPS1' <- getOpt noPS1Opt -< () 107 | let ghc = case ghcFlag of 108 | Nothing -> System 109 | -- First check for URLs (@//@ is not meaningful in Posix file 110 | -- paths), then versions and then default to path. 111 | Just s | "https://" == take 8 s -> Url s 112 | | "http://" == take 7 s -> Url s 113 | | isVersion s -> Release s 114 | | otherwise -> Tarball s 115 | skipSanityCheckFlag <- getOpt skipSanityOpt -< () 116 | noSharingFlag <- getOpt sharingOpt -< () 117 | bootstrapCabalFlag <- getOpt bootstrapCabalOpt -< () 118 | make <- getOpt makeOpt -< () 119 | returnA -< Options{ verbosity = verboseness 120 | , skipSanityCheck = skipSanityCheckFlag 121 | , envParentDir = parent 122 | , hsEnvName = name 123 | , ghcSource = ghc 124 | , makeCmd = make 125 | , noSharing = noSharingFlag 126 | , noPS1 = noPS1' 127 | , cabalBootstrap = bootstrapCabalFlag 128 | } 129 | where liftIO' = liftIO . const 130 | 131 | getArgs :: IO Options 132 | getArgs = parseArgs argParser versionString outro 133 | where 134 | outro = "Creates Virtual Haskell Environment in the current directory.\n" 135 | ++ "All files will be stored in the .hsenv[_NAME]/ subdirectory.\n" 136 | ++ "\n" 137 | ++ "To activate a sandbox in the current directory, run:\n" 138 | ++ "\n" 139 | ++ " source .hsenv/bin/activate\n" 140 | ++ "\n" 141 | ++ "To deactivate an active sandbox, run:\n" 142 | ++ "\n" 143 | ++ " deactivate_hsenv" 144 | 145 | isVersion :: String -> Bool 146 | isVersion s = case dropWhile isDigit s of 147 | "" -> s /= "" 148 | '.':s' -> s /= '.':s' && isVersion s' 149 | _ -> False 150 | -------------------------------------------------------------------------------- /src/Process.hs: -------------------------------------------------------------------------------- 1 | module Process ( outsideProcess 2 | , outsideProcess' 3 | , insideProcess 4 | , insideProcess' 5 | , ghcPkgDbPathLocation 6 | , externalGhcPkgDb 7 | ) where 8 | 9 | import HsenvMonad 10 | import Paths 11 | import Types 12 | 13 | import Util.IO (Environment, readProcessWithExitCodeInEnv, which) 14 | 15 | import Data.Maybe (fromMaybe) 16 | import System.Environment (getEnvironment) 17 | import System.Exit (ExitCode(..)) 18 | import System.FilePath (()) 19 | import System.Process (readProcessWithExitCode) 20 | 21 | runProcess :: Maybe Environment -> FilePath -> [String] -> Maybe String -> Hsenv String 22 | runProcess env prog args input = do 23 | case input of 24 | Nothing -> return () 25 | Just inp -> do 26 | trace "Using the following input:" 27 | indentMessages $ mapM_ trace $ lines inp 28 | 29 | let execProcess = case env of 30 | Nothing -> readProcessWithExitCode prog args (fromMaybe "" input) 31 | Just env' -> readProcessWithExitCodeInEnv env' prog args input 32 | 33 | (exitCode, output, errors) <- liftIO execProcess 34 | 35 | debug $ case exitCode of 36 | ExitSuccess -> "Process exited successfully" 37 | ExitFailure errCode -> "Process failed with exit code " ++ show errCode 38 | 39 | case output of 40 | "" -> trace "Empty process output" 41 | _ -> do 42 | trace "Process output:" 43 | indentMessages $ mapM_ trace $ lines output 44 | 45 | case errors of 46 | "" -> trace "Empty process error output" 47 | _ -> do 48 | trace "Process error output:" 49 | indentMessages $ mapM_ trace $ lines errors 50 | 51 | case exitCode of 52 | ExitSuccess -> return output 53 | ExitFailure errCode -> throwError $ HsenvException $ prog ++ " process failed with status " ++ show errCode 54 | 55 | -- run regular process, takes: 56 | -- * program name, looks for it in $PATH, 57 | -- * list of arguments 58 | -- * maybe standard input 59 | -- returns standard output 60 | outsideProcess :: String -> [String] -> Maybe String -> Hsenv String 61 | outsideProcess progName args input = do 62 | debug $ unwords $ ["Running outside process:", progName] ++ args 63 | indentMessages $ do 64 | trace $ unwords ["Looking for", progName, "in $PATH"] 65 | program <- liftIO $ which Nothing progName 66 | case program of 67 | Nothing -> throwError $ HsenvException $ unwords ["No", progName, "in $PATH"] 68 | Just programPath -> do 69 | trace $ unwords [progName, "->", programPath] 70 | runProcess Nothing programPath args input 71 | 72 | outsideProcess' :: String -> [String] -> Hsenv String 73 | outsideProcess' progName args = outsideProcess progName args Nothing 74 | 75 | -- returns path to GHC (installed from tarball) builtin package database 76 | externalGhcPkgDb :: Hsenv FilePath 77 | externalGhcPkgDb = do 78 | trace "Checking where GHC (installed from tarball) keeps its package database" 79 | indentMessages $ do 80 | dirStructure <- hseDirStructure 81 | let ghcPkg = ghcDir dirStructure "bin" "ghc-pkg" 82 | trace $ unwords ["Running process:", ghcPkg, "list"] 83 | ghcPkgOutput <- indentMessages $ runProcess Nothing ghcPkg ["list"] Nothing 84 | debug "Trying to parse ghc-pkg's output" 85 | case lines ghcPkgOutput of 86 | [] -> throwError $ HsenvException "ghc-pkg returned empty output" 87 | lineWithPath:_ -> 88 | case lineWithPath of 89 | "" -> throwError $ HsenvException "ghc-pkg's first line of output is empty" 90 | _ -> do 91 | -- ghc-pkg ends pkg db path with trailing colon 92 | -- but only when not run from the terminal 93 | let path = init lineWithPath 94 | debug $ "Found: " ++ path 95 | return path 96 | 97 | -- returns value of GHC_PACKAGE_PATH that should be used inside virtual environment 98 | -- defined in this module, because insideProcess needs it 99 | ghcPkgDbPathLocation :: Hsenv String 100 | ghcPkgDbPathLocation = do 101 | trace "Determining value of GHC_PACKAGE_PATH to be used inside virtual environment" 102 | dirStructure <- hseDirStructure 103 | ghc <- asks ghcSource 104 | case ghc of 105 | System -> return $ ghcPackagePath dirStructure 106 | _ -> do 107 | externalGhcPkgDbPath <- indentMessages externalGhcPkgDb 108 | return $ ghcPackagePath dirStructure ++ ":" ++ externalGhcPkgDbPath 109 | 110 | virtualEnvironment :: Hsenv Environment 111 | virtualEnvironment = do 112 | debug "Calculating unix env dictionary used inside virtual environment" 113 | indentMessages $ do 114 | env <- liftIO getEnvironment 115 | ghcPkgDb <- ghcPkgDbPathLocation 116 | debug $ "$GHC_PACKAGE_PATH=" ++ ghcPkgDb 117 | pathVar <- insidePathVar 118 | debug $ "$PATH=" ++ pathVar 119 | let varToBeOverridden var = var `elem` ["GHC_PACKAGE_PATH", "PATH"] 120 | strippedEnv = filter (not . varToBeOverridden . fst) env 121 | return $ [("GHC_PACKAGE_PATH", ghcPkgDb), ("PATH", pathVar)] ++ strippedEnv 122 | 123 | -- run process from inside the virtual environment, takes: 124 | -- * program name, looks for it in (in order): 125 | -- - cabal bin dir (e.g. .hsenv*/cabal/bin) 126 | -- - ghc bin dir (e.g. .hsenv*/ghc/bin), only when using ghc from tarball 127 | -- - $PATH 128 | -- * list of arguments 129 | -- * maybe standard input 130 | -- returns standard output 131 | -- process is run in altered environment (new $GHC_PACKAGE_PATH env var, 132 | -- adjusted $PATH var) 133 | insideProcess :: String -> [String] -> Maybe String -> Hsenv String 134 | insideProcess = insideProcess' False 135 | 136 | -- like insideProcess, but if skipGhcPkgPathVar is True, GHC_PACKAGE_PATH is not added 137 | insideProcess' :: Bool -> String -> [String] -> Maybe String -> Hsenv String 138 | insideProcess' skipGhcPkgPathVar progName args input = do 139 | debug $ unwords $ ["Running inside process:", progName] ++ args 140 | indentMessages $ do 141 | pathVar <- insidePathVar 142 | trace $ unwords ["Looking for", progName, "in", pathVar] 143 | program <- liftIO $ which (Just pathVar) progName 144 | case program of 145 | Nothing -> throwError $ HsenvException $ unwords ["No", progName, "in", pathVar] 146 | Just programPath -> do 147 | trace $ unwords [progName, "->", programPath] 148 | env <- virtualEnvironment 149 | let env' = if skipGhcPkgPathVar then 150 | filter (\(k, _) -> k /= "GHC_PACKAGE_PATH") env 151 | else 152 | env 153 | runProcess (Just env') programPath args input 154 | -------------------------------------------------------------------------------- /hsenv.el: -------------------------------------------------------------------------------- 1 | (require 'cl) ; for mapcar* block and return 2 | 3 | (defvar hsenv-active-environment nil) 4 | 5 | (defconst hsenv-path-prepend-file "path_var_prependix") 6 | (defconst hsenv-ghc-package-path-file "ghc_package_path_var") 7 | 8 | (defun hsenv-compare-ghc-version (version-string &optional threshold) 9 | (save-match-data 10 | (when (string-match "\\(\\([0-9]+\\.?\\)+\\)$" version-string) 11 | (let* ((threshold (or threshold (list 7 6 1))) 12 | (version (match-string 1 version-string)) 13 | (version-numbers 14 | (mapcar #'string-to-number (split-string version "\\.")))) 15 | (block nil 16 | (mapcar* #'(lambda (v1 v2) 17 | (when (< v1 v2) 18 | (return 'lt)) 19 | (when (> v1 v2) 20 | (return 'gt))) 21 | version-numbers 22 | threshold) 23 | 'eq))))) 24 | 25 | (defun hsenv-select-opt-suffix () 26 | (let ((cmp-result (hsenv-compare-ghc-version (shell-command-to-string "ghc --version")))) 27 | (unless cmp-result 28 | (error "Cannot get GHC version")) 29 | (if (eq 'lt cmp-result) 30 | "conf" 31 | "db"))) 32 | 33 | (defun hsenv-valid-dirp (hsenv-dir) 34 | (let ((valid (and (file-accessible-directory-p hsenv-dir) 35 | (file-readable-p 36 | (concat hsenv-dir hsenv-path-prepend-file)) 37 | (file-readable-p 38 | (concat hsenv-dir hsenv-ghc-package-path-file))))) 39 | (when (not valid) 40 | (message "The environment you provided is not a valid hsenv directory (%s)." 41 | hsenv-dir)) 42 | valid)) 43 | 44 | (defun hsenv-is-not-active () 45 | (let ((is-not-active (not hsenv-active-environment))) 46 | (when (not is-not-active) 47 | (message "An hsenv is already activated (%s)." 48 | (assoc-default 'dir hsenv-active-environment))) 49 | is-not-active)) 50 | 51 | (defun hsenv-is-active () 52 | (let ((is-active hsenv-active-environment)) 53 | (when (not is-active) 54 | (message "No hsenv currently activated.")) 55 | is-active)) 56 | 57 | (defun hsenv-read-file-content (hsenv-dir file) 58 | (with-temp-buffer 59 | (insert-file-contents (concat hsenv-dir file)) 60 | (replace-regexp-in-string "\n+$" "" (buffer-string)))) 61 | 62 | (defun hsenv-replace-pkg (template package-dbs) 63 | (apply #'concat 64 | (mapcar #'(lambda (db) 65 | (concat template db)) 66 | package-dbs))) 67 | 68 | (defun hsenv-activate-environment (hsenv-dir env env-name) 69 | "Activate the Virtual Haskell Environment in directory HSENV-DIR" 70 | (when (and (hsenv-valid-dirp hsenv-dir) 71 | (hsenv-is-not-active)) 72 | 73 | ; Prepend paths 74 | (let* ((new-hsenv-active-environment (list `(path-backup . ,(getenv "PATH")) 75 | `(exec-path-backup . ,exec-path) 76 | `(dir . ,hsenv-dir))) 77 | (path-prepend (hsenv-read-file-content hsenv-dir 78 | hsenv-path-prepend-file)) 79 | (package-db (hsenv-read-file-content hsenv-dir hsenv-ghc-package-path-file)) 80 | (package-dbs (split-string package-db ":")) 81 | (suffix (hsenv-select-opt-suffix))) 82 | (setenv "PATH" (concat path-prepend ":" (getenv "PATH"))) 83 | (setq exec-path (append (split-string path-prepend ":") exec-path)) 84 | (setenv "PACKAGE_DB_FOR_GHC" 85 | (concat "-no-user-package-" suffix 86 | (hsenv-replace-pkg (concat " -package-" suffix "=") package-dbs))) 87 | (setenv "PACKAGE_DB_FOR_CABAL" 88 | (hsenv-replace-pkg " --package-db=" package-dbs)) 89 | (setenv "PACKAGE_DB_FOR_GHC_PKG" 90 | (concat "--no-user-package-" suffix 91 | (hsenv-replace-pkg (concat " --package-" suffix "=") package-dbs))) 92 | (setenv "PACKAGE_DB_FOR_GHC_MOD" 93 | (concat "-g -no-user-package-" suffix 94 | (hsenv-replace-pkg (concat " -g -package-" suffix "=") package-dbs))) 95 | (setenv "HASKELL_PACKAGE_SANDBOX" package-db) 96 | (setenv "HSENV" env) 97 | (setenv "HSENV_NAME" env-name) 98 | ; Save an hsenv active environment and backup paths 99 | (setq hsenv-active-environment new-hsenv-active-environment) 100 | (message "Environment activated: %s" hsenv-dir)))) 101 | 102 | (defun hsenv-env-name-from-dir (directory) 103 | "Return the name of an environment based on DIRECTORY." 104 | (save-match-data 105 | (let ((offs (string-match "[.]hsenv\\([^\\/]*\\)$" directory))) 106 | (cond 107 | (offs 108 | (substring directory (+ 6 offs))) 109 | ((string-match "[.]hsenv$" directory) 110 | "(default)") 111 | (t 112 | (error "Not an hsenv directory %s" directory)))))) 113 | 114 | ;;; Tests: 115 | ;; (and (equal "foo" (hsenv-env-name-from-dir "/home/bar/baz/.hsenv_foo")) 116 | ;; (equal "foo" (hsenv-env-name-from-dir "/home/bar/.hsenv_boo/baz/.hsenv_foo")) 117 | ;; (equal "(default)" 118 | ;; (hsenv-env-name-from-dir "/home/bar/.hsenv_boo/baz/.hsenv"))) 119 | 120 | (defun hsenv-make-env (directory) 121 | (cons (hsenv-env-name-from-dir directory) directory)) 122 | 123 | (defun hsenv-env-name (env) 124 | (car env)) 125 | 126 | (defun hsenv-env-dir (env) 127 | (cdr env)) 128 | 129 | (defun hsenv-deactivate () 130 | "Deactivate the Virtual Haskell Environment" 131 | (interactive) 132 | (when (hsenv-is-active) 133 | ; Restore paths 134 | (setenv "PATH" (assoc-default 'path-backup hsenv-active-environment)) 135 | (setq exec-path (assoc-default 'exec-path-backup hsenv-active-environment)) 136 | ; Unset variables 137 | (setenv "PACKAGE_DB_FOR_GHC") 138 | (setenv "PACKAGE_DB_FOR_GHC_PKG") 139 | (setenv "PACKAGE_DB_FOR_GHC_MOD") 140 | (setenv "PACKAGE_DB_FOR_CABAL") 141 | (setenv "HSENV") 142 | (setenv "HSENV_NAME") 143 | (setenv "HASKELL_PACKAGE_SANDBOX") 144 | ; Destroy the hsenv active environment 145 | (let ((old-dir (cdr (assoc 'dir hsenv-active-environment)))) 146 | (setq hsenv-active-environment nil) 147 | (message "Environment deactivated: %s" old-dir)))) 148 | 149 | (defun hsenv-activate-dir (dir) 150 | (let ((environments (hsenv-list-environments dir))) 151 | (if (null environments) 152 | (message "Directory %s does not contain any hsenv." dir) 153 | (let* ((env-name 154 | (if (= 1 (length environments)) 155 | (hsenv-env-name (car environments)) 156 | (completing-read "Environment:" 157 | (mapcar #'hsenv-env-name environments)))) 158 | (env (assoc env-name environments))) 159 | (let* ((hsenv-dir-name (hsenv-env-dir env)) 160 | (hsenv-dir (file-name-as-directory hsenv-dir-name))) 161 | (hsenv-activate-environment hsenv-dir dir env-name)))))) 162 | 163 | (defun hsenv-list-environments (dir) 164 | "Returns an assoc list of all environments avaliable in DIR. 165 | 166 | The assoc list contains pairs of the form (NAME . DIRECTORY)." 167 | (let ((hsenv-dirs (directory-files dir t "^\\.hsenv\\(_.*\\)?$"))) 168 | (mapcar #'hsenv-make-env hsenv-dirs))) 169 | 170 | (defun hsenv-activate (&optional select-dir) 171 | "Activate a Virtual Haskell Environment" 172 | (interactive "P") 173 | (if (or select-dir 174 | (null (hsenv-list-environments default-directory))) 175 | (hsenv-activate-dir (read-directory-name "Directory:")) 176 | (hsenv-activate-dir default-directory))) 177 | 178 | (provide 'hsenv) 179 | -------------------------------------------------------------------------------- /src/CabalBootstrap.hs: -------------------------------------------------------------------------------- 1 | module CabalBootstrap (bootstrapCabal) where 2 | 3 | import qualified System.Directory as Dir 4 | import System.FilePath (()) 5 | import Network.URI (URI(..), URIAuth(..)) 6 | import Network.HTTP 7 | import Codec.Compression.GZip (decompress) 8 | import qualified Data.ByteString.Lazy as BS 9 | import Distribution.Hackage.DB hiding (map, foldr) 10 | import Prelude hiding (filter) 11 | import qualified Codec.Archive.Tar as Tar 12 | 13 | import Types 14 | import HsenvMonad 15 | import HsenvMonadUtils 16 | import Paths 17 | import Process (insideProcess, insideProcess', externalGhcPkgDb) 18 | import PackageManagement (insideGhcPkg, getHighestVersion) 19 | import Util.Cabal (prettyVersion, executableMatchesCabal) 20 | 21 | hackageDomain :: String 22 | hackageDomain = "hackage.haskell.org" 23 | 24 | indexURI :: URI 25 | indexURI = URI { uriScheme = "http:" 26 | , uriAuthority = Just URIAuth { uriUserInfo = "" 27 | , uriRegName = hackageDomain 28 | , uriPort = "" 29 | } 30 | , uriPath = "/packages/index.tar.gz" 31 | , uriQuery = "" 32 | , uriFragment = "" 33 | } 34 | 35 | getCIBURI :: Version -> URI 36 | getCIBURI version = indexURI {uriPath = cibpath} 37 | where cibpath = concat [ "/package/cabal-install-bundle-" 38 | , ver 39 | , "/cabal-install-bundle-" 40 | , ver 41 | , ".tar.gz" 42 | ] 43 | ver = prettyVersion version 44 | 45 | downloadHTTPUncompress :: URI -> Hsenv BS.ByteString 46 | downloadHTTPUncompress uri = do 47 | result <- liftIO $ simpleHTTP $ mkRequest GET uri 48 | case result of 49 | Left err -> throwError $ HsenvException $ show err 50 | Right response -> return $ decompress $ rspBody response 51 | 52 | fetchHackageIndex :: Hsenv () 53 | fetchHackageIndex = do 54 | debug "Checking if Hackage index is already downloaded" 55 | noSharingFlag <- asks noSharing 56 | dirStructure <- hseDirStructure 57 | hackageCache <- indentMessages $ 58 | if noSharingFlag then 59 | return $ cabalDir dirStructure "packages" 60 | else do 61 | cabalInstallDir <- liftIO $ Dir.getAppUserDataDirectory "cabal" 62 | return $ cabalInstallDir "packages" 63 | let cacheDir = hackageCache hackageDomain 64 | hackageData = cacheDir "00-index.tar" 65 | dataExists <- liftIO $ Dir.doesFileExist hackageData 66 | if dataExists then 67 | indentMessages $ debug "It is" 68 | else do 69 | indentMessages $ debug "It's not" 70 | info "Downloading Hackage index" 71 | liftIO $ Dir.createDirectoryIfMissing True cacheDir 72 | tarredIndex <- downloadHTTPUncompress indexURI 73 | liftIO $ BS.writeFile hackageData tarredIndex 74 | 75 | readHackageIndex :: Hsenv Hackage 76 | readHackageIndex = do 77 | noSharingFlag <- asks noSharing 78 | dirStructure <- hseDirStructure 79 | hackageCache <- indentMessages $ 80 | if noSharingFlag then 81 | return $ cabalDir dirStructure "packages" 82 | else do 83 | cabalInstallDir <- liftIO $ Dir.getAppUserDataDirectory "cabal" 84 | return $ cabalInstallDir "packages" 85 | let cacheDir = hackageCache hackageDomain 86 | hackageIndexLocation = cacheDir "00-index.tar" 87 | liftIO $ readHackage' hackageIndexLocation 88 | 89 | chooseCIBVersion :: Hackage -> Version -> Hsenv Version 90 | chooseCIBVersion hackage cabalVersion = do 91 | debug "Choosing the right cabal-install-bundle version" 92 | let cibs = hackage ! "cabal-install-bundle" 93 | cibVersions = keys cibs 94 | trace $ "Found cabal-install-bundle versions: " ++ unwords (map prettyVersion cibVersions) 95 | let matchingCIBs = filter (executableMatchesCabal "cabal" cabalVersion) cibs 96 | matchingCIBVersions = keys matchingCIBs 97 | debug $ "cabal-install-bundle versions matching Cabal library: " 98 | ++ unwords (map prettyVersion matchingCIBVersions) 99 | case matchingCIBVersions of 100 | [] -> throwError $ HsenvException $ "No cabal-install-bundle packages " 101 | ++ "matching installed Cabal library" 102 | v:vs -> return $ foldr max v vs 103 | 104 | runSetupHsConfigure :: FilePath -> Hsenv () 105 | runSetupHsConfigure setupHsPath = do 106 | cabalVersion <- getHighestVersion (PackageName "Cabal") insideGhcPkg 107 | dirStructure <- hseDirStructure 108 | let cabal_1_16_0_version = Version [1, 16, 0] [] 109 | _ <- indentMessages $ 110 | if cabalVersion >= cabal_1_16_0_version then do 111 | debug "Cabal has version >= 1.16.0, using new --package-db args" 112 | debug " instead of relying on $GHC_PACKAGE_PATH variable" 113 | ghcPkgDbPath <- indentMessages externalGhcPkgDb 114 | let args = [ setupHsPath 115 | , "configure" 116 | , "--prefix=" ++ cabalDir dirStructure 117 | , "--package-db=" ++ ghcPkgDbPath 118 | , "--package-db=" ++ ghcPackagePath dirStructure 119 | ] 120 | insideProcess' True "runghc" args Nothing 121 | else do 122 | let args = [ setupHsPath 123 | , "configure" 124 | , "--prefix=" ++ cabalDir dirStructure 125 | , "--user" 126 | ] 127 | insideProcess "runghc" args Nothing 128 | return () 129 | 130 | installCabal :: Version -> Hsenv () 131 | installCabal cabalVersion = do 132 | fetchHackageIndex 133 | hackageIndex <- readHackageIndex 134 | cibVersion <- chooseCIBVersion hackageIndex cabalVersion 135 | info $ "Using cabal-install-bundle version " ++ prettyVersion cibVersion 136 | let url = getCIBURI cibVersion 137 | trace $ "Download URL: " ++ show url 138 | tarredPkg <- downloadHTTPUncompress url 139 | runInTmpDir $ do 140 | cwd <- liftIO Dir.getCurrentDirectory 141 | trace $ "Unpacking package in " ++ cwd 142 | liftIO $ Tar.unpack cwd $ Tar.read tarredPkg 143 | debug "Configuring cabal-install-bundle" 144 | let pkgDir = cwd "cabal-install-bundle-" ++ prettyVersion cibVersion 145 | setup = pkgDir "Setup.hs" 146 | liftIO $ Dir.setCurrentDirectory pkgDir 147 | let cabalSetup args = insideProcess "runghc" (setup:args) Nothing 148 | _ <- runSetupHsConfigure setup 149 | debug "Building cabal-install-bundle" 150 | _ <- cabalSetup ["build"] 151 | debug "Installing cabal-install-bundle" 152 | _ <- cabalSetup ["install"] 153 | return () 154 | 155 | bootstrapCabal :: Hsenv () 156 | bootstrapCabal = action "Bootstrapping cabal-install" $ do 157 | cabalVersion <- getHighestVersion (PackageName "Cabal") insideGhcPkg 158 | debug $ "Cabal library has version " ++ prettyVersion cabalVersion 159 | trace "Checking where cached version of cabal-install would be" 160 | versionedCabInsCachePath <- cachedCabalInstallPath cabalVersion 161 | let versionedCabInsPath = versionedCabInsCachePath "cabal" 162 | trace $ "It would be at " ++ versionedCabInsPath 163 | dirStructure <- hseDirStructure 164 | flag <- liftIO $ Dir.doesFileExist versionedCabInsPath 165 | if flag then do 166 | info $ "Using cached copy of cabal-install for Cabal-" 167 | ++ prettyVersion cabalVersion 168 | let cabInsTarget = cabalBinDir dirStructure "cabal" 169 | liftIO $ Dir.createDirectoryIfMissing True $ cabalBinDir dirStructure 170 | liftIO $ Dir.copyFile versionedCabInsPath cabInsTarget 171 | else do 172 | info $ concat [ "No cached copy of cabal-install for Cabal-" 173 | , prettyVersion cabalVersion 174 | , ", proceeding with downloading and compilation of" 175 | , " cabal-install-bundle." 176 | , " This can take a few minutes" 177 | ] 178 | installCabal cabalVersion 179 | let cabInsPath = cabalBinDir dirStructure "cabal" 180 | debug $ concat [ "Copying compiled cabal-install-bundle binary" 181 | , " for future use (to " 182 | , versionedCabInsPath 183 | , ")" 184 | ] 185 | liftIO $ Dir.createDirectoryIfMissing True versionedCabInsCachePath 186 | liftIO $ Dir.copyFile cabInsPath versionedCabInsPath 187 | -------------------------------------------------------------------------------- /hsenv.cabal: -------------------------------------------------------------------------------- 1 | Name: hsenv 2 | 3 | Version: 0.4 4 | 5 | Synopsis: Virtual Haskell Environment builder 6 | 7 | Description: hsenv is a tool (inspired by Python's virtualenv) to create isolated Haskell environments. 8 | . 9 | It creates a sandboxed environment in a .hsenv/ sub-directory 10 | of your project, which, when activated, allows you to use regular Haskell tools 11 | (ghc, ghci, ghc-pkg, cabal) to manage your Haskell code and environment. 12 | It's possible to create an environment, that uses different GHC version 13 | than your currently installed. Very simple emacs integration mode is included. 14 | . 15 | Basic usage 16 | . 17 | First, choose a directory where you want to keep your 18 | sandboxed Haskell environment, usually a good choice is a directory containing 19 | your cabalized project (if you want to work on a few projects 20 | (perhaps an app and its dependent library), just choose any of them, 21 | it doesn't really matter). Enter that directory: 22 | . 23 | > cd ~/projects/foo 24 | . 25 | Next, create your new isolated Haskell environment 26 | (this is a one time only (per environment) step): 27 | . 28 | > hsenv 29 | . 30 | Now, every time you want to use this environment, you have to activate it: 31 | . 32 | > source .hsenv/bin/activate 33 | . 34 | That's it! Now it's possible to use all regular Haskell tools like usual, 35 | but it won't affect your global/system's Haskell environment, and also 36 | your per-user environment (from ~/.cabal and ~/.ghc) will stay the same. 37 | All cabal-installed packages will be private to this environment, 38 | and also the external environments (global and user) will not affect it 39 | (this environment will only inherit very basic packages, 40 | mostly ghc and Cabal and their deps). 41 | . 42 | When you're done working with this environment, enter command 'deactivate_hsenv', 43 | or just close the current shell (with exit). 44 | . 45 | > deactivate_hsenv 46 | . 47 | Named vs Unnamed Environments 48 | . 49 | By default, hsenv creates an "unnamed" environment, but sometimes for 50 | particular use cases you might want to create different environments under 51 | the same directory. This is achievable creating a "named" environment. To 52 | do that, just pass the flag "--name=" to hsenv: 53 | . 54 | hsenv --name= 55 | . 56 | This will make hsenv to generate a folder of the form ".hsenv_". 57 | . 58 | Advanced usage. 59 | . 60 | The only advanced usage is using different GHC version. This can be useful to test your code 61 | against different GHC version (even against nightly builds). 62 | . 63 | First, download binary distribution of GHC for your platform 64 | (e.g. ghc-7.0.4-i386-unknown-linux.tar.bz2), then create a new environment using that GHC 65 | . 66 | > hsenv --ghc=/path/to/ghc_something.tar.bz2 67 | . 68 | Then, proceed (with [de]activation) as in basic case. 69 | . 70 | Fetching and downloading a remote version of GHC 71 | . 72 | Recent versions of hsenv include the possibility to automatically download 73 | and install a GHC version directly from the GHC main repository. To do that, 74 | as regards the example above, all you need to do is to pass the desired version 75 | of GHC you want to install: 76 | . 77 | > hsenv --ghc=7.4.1 78 | . 79 | Or a valid URL pointing to a compressed GHC archive: 80 | . 81 | > hsenv --ghc=http://www.haskell.org/ghc/dist/7.6.3/ghc-7.6.3-x86_64-apple-darwin.tar.bz2 82 | . 83 | Misc 84 | . 85 | hsenv has been tested on i386 Linux and FreeBSD systems, 86 | but it should work on any Posix platform. External (from tarball) GHC feature 87 | requires binary GHC distribution compiled for your platform, 88 | that can be extracted with tar and installed with 89 | "./configure --prefix=PATH; make install". 90 | . 91 | For more info please consult "hsenv --help" or the attached README file. 92 | 93 | Homepage: https://github.com/tmhedberg/hsenv 94 | 95 | License: BSD3 96 | 97 | License-file: LICENSE 98 | 99 | Author: Bartosz Ćwikłowski 100 | 101 | Maintainer: Taylor Hedberg 102 | 103 | Copyright: (c) 2011 Bartosz Ćwikłowski 104 | 105 | Category: Development 106 | 107 | Build-type: Simple 108 | 109 | Stability: provisional 110 | 111 | Bug-reports: https://github.com/tmhedberg/hsenv/issues 112 | 113 | Package-url: http://hackage.haskell.org/package/hsenv 114 | 115 | Tested-with: GHC == 6.12.3, GHC == 7.0.4, GHC == 7.4.2, GHC == 7.6.1 116 | 117 | Data-files: hsenv.el, README.md 118 | 119 | Extra-source-files: skeletons/activate, skeletons/cabal, skeletons/cabal_config, skeletons/ghc, skeletons/ghc-mod, 120 | skeletons/ghc-pkg, skeletons/ghci, skeletons/runghc 121 | 122 | Cabal-version: >=1.6 123 | 124 | Executable hsenv 125 | 126 | Main-is: hsenv.hs 127 | 128 | Hs-source-dirs: src 129 | 130 | cpp-options: -Dcabal 131 | 132 | Ghc-options: -threaded -Wall 133 | 134 | Build-depends: base >= 4.2.0.0 && < 4.7 135 | , process >= 1.0.1.2 && < 1.2 136 | , filepath >= 1.1.0.3 && < 1.4 137 | , directory >= 1.0.1.0 && < 1.3 138 | , Cabal >= 1.8.0.6 && < 1.17 139 | , mtl >= 1.1.0.2 && < 2.2 140 | , bytestring >= 0.9.1.7 && < 0.11 141 | , file-embed >= 0.0.4.1 && < 0.1 142 | , split >= 0.1.4 && < 0.3 143 | , safe >= 0.3 && < 0.4 144 | , unix >= 2.0 && < 2.7 145 | , http-streams >= 0.6.0.2 && <= 0.7 146 | , io-streams >= 1.1.0.0 && <= 1.2.0.0 147 | , hackage-db >= 1.5 && < 1.6 148 | , zlib >= 0.5.3.3 && < 0.6 149 | , HTTP >= 4000.2.3 && < 4000.3 150 | , network >= 2.3.0.13 && < 2.5 151 | , tar >= 0.4 && < 0.5 152 | 153 | Other-modules: Util.Cabal 154 | , Util.Args 155 | , Util.Args.Args 156 | , Util.Args.ArgArrow 157 | , Util.Args.ArgDescr 158 | , Util.Args.RawArgs 159 | , Util.Args.GetOpt 160 | , Util.Args.Usage 161 | , Util.List 162 | , Util.StaticArrowT 163 | , Util.String 164 | , Util.Template 165 | , Util.IO 166 | , Util.WordWrap 167 | , Skeletons 168 | , Types 169 | , HsenvMonad 170 | , Args 171 | , Paths 172 | , SanityCheck 173 | , Process 174 | , PackageManagement 175 | , Actions 176 | 177 | Source-repository head 178 | Type: git 179 | Location: git://github.com/tmhedberg/hsenv.git 180 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | hsenv - Virtual Haskell Environment 2 | =================================== 3 | 4 | What is it? 5 | ----------- 6 | hsenv is a tool (inspired by Python's virtualenv) 7 | to create isolated Haskell environments. 8 | 9 | 10 | What does it do? 11 | ---------------- 12 | It creates a sandboxed environment in a .hsenv/ subdirectory of your project, 13 | which, when activated, allows you to use regular Haskell tools (ghc, ghci, 14 | ghc-pkg, cabal) to manage your Haskell code and environment. It's possible to 15 | create an environment, that uses a different GHC version than your currently 16 | installed system GHC version. Very simple emacs integration mode is included. 17 | 18 | Basic usage 19 | ----------- 20 | First, choose a directory where you want to keep your 21 | sandboxed Haskell environment, usually a good choice is a directory containing 22 | your cabalized project (if you want to work on a few projects 23 | (perhaps an app and its dependent library), just choose any of them, 24 | it doesn't really matter). Enter that directory: 25 | 26 | ```bash 27 | cd ~/projects/foo 28 | ``` 29 | 30 | Next, create your new isolated Haskell environment 31 | (this is a one-time-only (per environment) step): 32 | 33 | ```bash 34 | hsenv 35 | ``` 36 | 37 | Now, every time you want to use this environment, you have to activate it: 38 | 39 | ```bash 40 | source .hsenv/bin/activate 41 | ``` 42 | 43 | That's it! Now it's possible to use all regular Haskell tools like usual, but 44 | it won't affect your global/system Haskell environment, and also your per-user 45 | environment (from ~/.cabal and ~/.ghc) will stay the same. All cabal-installed 46 | packages will be private to this environment, and the external environments 47 | (global and user) will not affect it (this environment will only inherit very 48 | basic packages, mostly ghc and Cabal and their deps). 49 | 50 | When you're done working with this environment, enter command `deactivate_hsenv`, 51 | or just close the current shell (with exit). 52 | 53 | ```bash 54 | deactivate_hsenv 55 | ``` 56 | 57 | Named vs Unnamed Environments 58 | ----------------------------- 59 | 60 | By default, hsenv creates an "unnamed" environment, but sometimes for 61 | particular use cases you might want to create different environments under 62 | the same directory. This is achievable creating a "named" environment. To 63 | do that, just pass the flag `--name=` to hsenv: 64 | 65 | ```bash 66 | hsenv --name= 67 | ``` 68 | 69 | This will make hsenv generate a folder of the form `.hsenv_`. 70 | 71 | Customization 72 | ------------- 73 | 74 | If you want to customize activation and deactivation, create one or more of the 75 | following files in ~/.hsenv/bin/: pre-activate, post-activate, pre-deactivate, 76 | post-deactivate. These shell scripts will be sourced automatically by the main 77 | activation script. 78 | 79 | Advanced usage 80 | -------------- 81 | Here's the most advanced usage of hsenv. Let's say you want to: 82 | 83 | * Hack on a json library 84 | * Do so comfortably 85 | * Use your own version of the parsec library 86 | * And do all this using the nightly version of GHC 87 | 88 | First, download the binary distribution of GHC for your platform 89 | (e.g. ghc-7.3.20111105-i386-unknown-linux.tar.bz2). 90 | 91 | Create a directory for you environment: 92 | 93 | ```bash 94 | mkdir /tmp/test 95 | cd /tmp/test 96 | ``` 97 | 98 | Then, create a new environment using that GHC: 99 | 100 | ```bash 101 | hsenv --name=test --ghc=/path/to/ghc-7.3.20111105-i386-unknown-linux.tar.bz2 102 | ``` 103 | 104 | Activate it: 105 | 106 | ```bash 107 | source .hsenv_test/bin/activate 108 | ``` 109 | 110 | Download a copy of json library and your private version of parsec: 111 | 112 | ```bash 113 | darcs get http://patch-tag.com/r/Paczesiowa/parsec 114 | cabal unpack json 115 | ``` 116 | 117 | Install parsec: 118 | 119 | ```bash 120 | cd parsec2 121 | cabal install 122 | ``` 123 | 124 | Install the rest of the json deps: 125 | 126 | ```bash 127 | cd ../json-0.5 128 | cabal install --only-dependencies 129 | ``` 130 | 131 | Now, let's say you want to hack on Parsec module of json library. 132 | Open it in emacs: 133 | 134 | ```bash 135 | emacsclient Text/JSON/Parsec.hs 136 | ``` 137 | 138 | Activate the virtual environment (hsenv must be required earlier): 139 | 140 | ``` 141 | M-x hsenv-activate /tmp/test/ 142 | ``` 143 | 144 | Edit some code and load it in ghci using 'C-c C-l'. If it type checks, 145 | you can play around with the code using nightly version of ghci running 146 | in your virtual environment. When you're happy with the code, exit emacs 147 | and install your edited json library: 148 | 149 | ```bash 150 | cabal install 151 | ``` 152 | 153 | And that's it. 154 | 155 | Fetching and downloading a remote version of GHC 156 | ------------------------------------------------ 157 | 158 | Recent versions of hsenv include the possibility to automatically download and 159 | install a GHC version directly from the GHC main repository. To do that, all 160 | you need to do is to pass the desired version of GHC you want to install: 161 | 162 | ```bash 163 | hsenv --ghc=7.4.1 164 | ``` 165 | 166 | Or a valid URL pointing to a compressed GHC archive: 167 | 168 | ```bash 169 | hsenv --ghc=http://www.haskell.org/ghc/dist/7.6.3/ghc-7.6.3-x86_64-apple-darwin.tar.bz2 170 | ``` 171 | 172 | Misc 173 | ---- 174 | 175 | hsenv has been tested on Linux, Mac OS X, and FreeBSD systems, but it should 176 | work on any POSIX platform. The external (from tarball) GHC feature requires 177 | a binary GHC distribution compiled for your platform which that can be 178 | extracted with tar and installed with "./configure --prefix=PATH; make 179 | install". 180 | 181 | FAQ 182 | --- 183 | **Q: Can I use it together with tools like cabal-dev or capri?** 184 | 185 | A: No. All these tools work more or less the same (wrapping cabal command, 186 | setting GHC_PACKAGE_PATH env variable), so something will probably break. 187 | 188 | 189 | **Q: Using GHC from tarball fails with a bunch of make tool gibberish on 190 | FreeBSD. What do I do?** 191 | 192 | A: Try the '--make-cmd=gmake' switch. 193 | 194 | 195 | **Q: Can I use hsenv inside hsenv?** 196 | 197 | A: No. It may be supported in future versions. 198 | 199 | 200 | **Q: Does it work on x64 systems?** 201 | 202 | A: Yes. 203 | 204 | 205 | **Q: Will it work on Mac?** 206 | 207 | A: Yes. 208 | 209 | 210 | **Q: Will it work on Windows?** 211 | 212 | A: I really doubt it would even compile. I don't have access to any Windows 213 | machines, so you're on your own, but patches/ideas/questions are welcome. 214 | Maybe it would work on Cygwin. 215 | 216 | 217 | **Q: Does it require Bash?** 218 | 219 | A: No, it should work with any POSIX-compliant shell. It's been tested with 220 | bash, bash --posix, dash, zsh and ksh. 221 | 222 | 223 | **Q: Can I use it with a different haskell package repository than hackage?** 224 | 225 | A: Yes, just adjust the url in .hsenv/cabal/config file. 226 | 227 | 228 | **Q: How do I remove the whole virtual environment?** 229 | 230 | A: If it's activated - 'deactivate_hsenv' it. Then, delete 231 | the .hsenv/ directory. 232 | 233 | 234 | **Q: Is every environment completely separate from other environments and 235 | the system environment?** 236 | 237 | A: Yes. The only (minor) exception is ghci history - there's only one 238 | per user history file. Also, if you alter your system's GHC, then 239 | virtual environments using system's GHC copy will probably break. 240 | Virtual environments using GHC from a tarball should continue to work. 241 | 242 | 243 | **Q: Can I share one cabalized project directory among multiple environments 244 | (e.g. build a cabalized project in the same directory using different 245 | environments)?** 246 | 247 | A: Yes. hsenv also overrides cabal with a wrapper, that will force using 248 | different build directories, so there shouldn't be even any recompilation 249 | between different environments. 250 | 251 | 252 | **Q: Is it possible to activate an environment upon entering its directory?** 253 | 254 | A: Yes, if you really know what you're doing. Here's a snippet for bash, which 255 | will activate both named and unnamed environments: 256 | 257 | ```bash 258 | function precmd() { 259 | if [[ -z $HSENV ]]; then 260 | NUMBER_OF_ENVS=$(find . -maxdepth 1 -type d -name ".hsenv*" | wc -l) 261 | case ${NUMBER_OF_ENVS} in 262 | "0") ;; 263 | "1") source .hsenv*/bin/activate;; 264 | *) echo multiple environments, manual activaton required;; 265 | esac 266 | fi 267 | } 268 | export PROMPT_COMMAND=precmd 269 | ``` 270 | 271 | 272 | **Q: Can I use hsenv on a machine, that doesn't have cabal binary (from 273 | cabal-install package) installed?** 274 | 275 | A: Yes. Just use the '--bootstrap-cabal' switch. In fact, you can use hsenv on 276 | a machine that doesn't have anything Haskell-related installed - just 277 | combine '--ghc=' and '--bootstrap-cabal' options. 278 | -------------------------------------------------------------------------------- /src/Actions.hs: -------------------------------------------------------------------------------- 1 | module Actions ( cabalUpdate 2 | , installCabalConfig 3 | , installCabalWrapper 4 | , installActivateScript 5 | , installSimpleWrappers 6 | , installProgSymlinks 7 | , symlinkToSkeleton 8 | , copyBaseSystem 9 | , initGhcDb 10 | , installGhc 11 | , createDirStructure 12 | , bootstrapCabal 13 | , initDotHsenvDir 14 | ) where 15 | 16 | import Control.Monad 17 | import System.Directory 18 | import System.FilePath (()) 19 | import System.Info (arch, os) 20 | import System.Posix hiding (createDirectory, version) 21 | import Distribution.Version (Version (..)) 22 | import Distribution.Package (PackageName(..)) 23 | import Safe (lastMay) 24 | import Data.List (intercalate) 25 | import Data.Maybe (fromMaybe, isJust) 26 | 27 | import Network.Http.Client 28 | import qualified Data.ByteString.Char8 as C8 29 | import qualified System.IO.Streams as S 30 | 31 | import HsenvMonad 32 | import HsenvMonadUtils 33 | import Types 34 | import Paths 35 | import PackageManagement 36 | import Process 37 | import Util.Template (substs) 38 | import Util.IO (makeExecutable) 39 | import Skeletons 40 | import CabalBootstrap (bootstrapCabal) 41 | 42 | -- update cabal package info inside Virtual Haskell Environment 43 | cabalUpdate :: Hsenv () 44 | cabalUpdate = do 45 | noSharingFlag <- asks noSharing 46 | if noSharingFlag then do 47 | debug "Sharing user-wide ~/.cabal/packages disabled" 48 | cabalUpdate' 49 | else do 50 | debug "Sharing user-wide ~/.cabal/packages enabled, checking if data is already downloaded" 51 | cabalInstallDir <- liftIO $ getAppUserDataDirectory "cabal" 52 | let hackageData = foldl () cabalInstallDir [ "packages" 53 | , "hackage.haskell.org" 54 | , "00-index.tar" 55 | ] 56 | dataExists <- liftIO $ doesFileExist hackageData 57 | if dataExists then do 58 | info "Skipping 'cabal update' step, Hackage download cache already downloaded" 59 | info " to ~/.cabal/packages/. You can update it manually with 'cabal update'" 60 | info " (from inside or outside the virtual environment)." 61 | else do 62 | debug "No user-wide Hackage cache data downloaded" 63 | cabalUpdate' 64 | where cabalUpdate' = do 65 | cabalConfig <- cabalConfigLocation 66 | info "Updating cabal package database inside Virtual Haskell Environment." 67 | _ <- indentMessages $ insideProcess "cabal" ["--config-file=" ++ cabalConfig, "update"] Nothing 68 | return () 69 | 70 | 71 | -- install cabal wrapper (in bin/ directory) inside virtual environment dir structure 72 | installCabalWrapper :: Hsenv () 73 | installCabalWrapper = do 74 | cabalConfig <- cabalConfigLocation 75 | dirStructure <- hseDirStructure 76 | hsEnvName' <- asks hsEnvName 77 | let cabalWrapper = hsEnvBinDir dirStructure "cabal" 78 | info $ concat [ "Installing cabal wrapper using " 79 | , cabalConfig 80 | , " at " 81 | , cabalWrapper 82 | ] 83 | let cabalWrapperContents = substs [ ("", cabalConfig) 84 | , ("", fromMaybe "" hsEnvName')] cabalWrapperSkel 85 | indentMessages $ do 86 | trace "cabal wrapper contents:" 87 | indentMessages $ mapM_ trace $ lines cabalWrapperContents 88 | liftIO $ writeFile cabalWrapper cabalWrapperContents 89 | liftIO $ makeExecutable cabalWrapper 90 | 91 | installActivateScriptSupportFiles :: Hsenv () 92 | installActivateScriptSupportFiles = do 93 | debug "installing supporting files" 94 | dirStructure <- hseDirStructure 95 | ghc <- asks ghcSource 96 | indentMessages $ do 97 | let pathVarPrependixLocation = hsEnvDir dirStructure "path_var_prependix" 98 | pathVarElems = 99 | case ghc of 100 | System -> [hsEnvBinDir dirStructure, cabalBinDir dirStructure] 101 | _ -> [ hsEnvBinDir dirStructure 102 | , cabalBinDir dirStructure 103 | , ghcBinDir dirStructure 104 | ] 105 | pathVarPrependix = intercalate ":" pathVarElems 106 | debug $ "installing path_var_prependix file to " ++ pathVarPrependixLocation 107 | indentMessages $ trace $ "path_var_prependix contents: " ++ pathVarPrependix 108 | liftIO $ writeFile pathVarPrependixLocation pathVarPrependix 109 | ghcPkgDbPath <- indentMessages ghcPkgDbPathLocation 110 | let ghcPackagePathVarLocation = hsEnvDir dirStructure "ghc_package_path_var" 111 | ghcPackagePathVar = ghcPkgDbPath 112 | debug $ "installing ghc_package_path_var file to " ++ ghcPackagePathVarLocation 113 | indentMessages $ trace $ "path_var_prependix contents: " ++ ghcPackagePathVar 114 | liftIO $ writeFile ghcPackagePathVarLocation ghcPackagePathVar 115 | 116 | -- install activate script (in bin/ directory) inside virtual environment dir structure 117 | installActivateScript :: Hsenv () 118 | installActivateScript = do 119 | info "Installing activate script" 120 | hsEnvName' <- asks hsEnvName 121 | noModifyPS1 <- asks noPS1 122 | dirStructure <- hseDirStructure 123 | ghcPkgDbPath <- indentMessages ghcPkgDbPathLocation 124 | let activateScript = hsEnvBinDir dirStructure "activate" 125 | indentMessages $ debug $ "using location: " ++ activateScript 126 | let activateScriptContents = 127 | substs [ ("", fromMaybe "" hsEnvName') 128 | , ("", hsEnvDir dirStructure) 129 | , ("", hsEnv dirStructure) 130 | , ("", ghcPkgDbPath) 131 | , ("", hsEnvBinDir dirStructure) 132 | , ("", cabalBinDir dirStructure) 133 | , ("", ghcBinDir dirStructure) 134 | , ("", if noModifyPS1 then "false" else "true") 135 | ] activateSkel 136 | indentMessages $ do 137 | trace "activate script contents:" 138 | indentMessages $ mapM_ trace $ lines activateScriptContents 139 | liftIO $ writeFile activateScript activateScriptContents 140 | indentMessages installActivateScriptSupportFiles 141 | 142 | -- install cabal's config file (in cabal/ directory) inside virtual environment dir structure 143 | installCabalConfig :: Hsenv () 144 | installCabalConfig = do 145 | cabalConfig <- cabalConfigLocation 146 | dirStructure <- hseDirStructure 147 | noSharingFlag <- asks noSharing 148 | hackageCache <- indentMessages $ 149 | if noSharingFlag then do 150 | info "Using private Hackage download cache directory" 151 | return $ cabalDir dirStructure "packages" 152 | else do 153 | info "Using user-wide (~/.cabal/packages) Hackage download cache directory" 154 | cabalInstallDir <- liftIO $ getAppUserDataDirectory "cabal" 155 | return $ cabalInstallDir "packages" 156 | info $ "Installing cabal config at " ++ cabalConfig 157 | let cabalConfigContents = substs [ ("", ghcPackagePath dirStructure) 158 | , ("", cabalDir dirStructure) 159 | , ("", hackageCache) 160 | ] cabalConfigSkel 161 | indentMessages $ do 162 | trace "cabal config contents:" 163 | indentMessages $ mapM_ trace $ lines cabalConfigContents 164 | liftIO $ writeFile cabalConfig cabalConfigContents 165 | 166 | installSimpleWrappers :: Hsenv () 167 | installSimpleWrappers = mapM_ installSimpleWrapper simpleWrappers 168 | 169 | installSimpleWrapper :: (String, String) -> Hsenv () 170 | installSimpleWrapper (targetFilename, skeleton) = do 171 | ghcPkgDbPath <- indentMessages ghcPkgDbPathLocation 172 | dirStructure <- hseDirStructure 173 | let ghcWrapperContents = 174 | substs [("", ghcPkgDbPath)] skeleton 175 | ghcWrapper = hsEnvBinDir dirStructure targetFilename 176 | liftIO $ writeFile ghcWrapper ghcWrapperContents 177 | liftIO $ makeExecutable ghcWrapper 178 | 179 | installProgSymlinks :: Hsenv () 180 | installProgSymlinks = mapM_ installSymlink extraProgs 181 | 182 | extraProgs :: [String] 183 | extraProgs = [ "alex" 184 | , "ar" 185 | , "c2hs" 186 | , "cpphs" 187 | , "ffihugs" 188 | , "gcc" 189 | , "greencard" 190 | , "haddock" 191 | , "happy" 192 | , "hmake" 193 | , "hpc" 194 | , "hsc2hs" 195 | , "hscolour" 196 | , "hugs" 197 | , "jhc" 198 | , "ld" 199 | , "lhc" 200 | , "lhc-pkg" 201 | , "nhc98" 202 | , "pkg-config" 203 | , "ranlib" 204 | , "strip" 205 | , "tar" 206 | , "uhc" 207 | ] 208 | 209 | installSymlink :: String -> Hsenv () 210 | installSymlink prog = do 211 | dirStructure <- hseDirStructure 212 | ghcSourceOpt <- asks ghcSource 213 | mPrivateLoc <- case ghcSourceOpt of 214 | System -> return Nothing 215 | _ -> liftIO $ findExecutable $ ghcDir dirStructure "bin" prog 216 | mSystemLoc <- liftIO $ findExecutable prog 217 | let mProgLoc = mPrivateLoc `mplus` mSystemLoc 218 | when (isJust mProgLoc) $ do 219 | let Just progLoc = mProgLoc 220 | liftIO $ createSymbolicLink progLoc $ hsEnvBinDir dirStructure prog 221 | 222 | -- | Install a symbolic link to a skeleton script in hsenv's bin directory 223 | symlinkToSkeleton :: String -- ^ Name of skeleton 224 | -> String -- ^ Name of link 225 | -> Hsenv () 226 | symlinkToSkeleton skel link = do 227 | dirStructure <- hseDirStructure 228 | let prependBinDir = (hsEnvBinDir dirStructure ) 229 | liftIO $ createSymbolicLink (prependBinDir skel) (prependBinDir link) 230 | 231 | createDirStructure :: Hsenv () 232 | createDirStructure = do 233 | dirStructure <- hseDirStructure 234 | info "Creating Virtual Haskell directory structure" 235 | indentMessages $ do 236 | debug $ "hsenv directory: " ++ hsEnvDir dirStructure 237 | liftIO $ createDirectory $ hsEnvDir dirStructure 238 | debug $ "cabal directory: " ++ cabalDir dirStructure 239 | liftIO $ createDirectory $ cabalDir dirStructure 240 | debug $ "hsenv bin directory: " ++ hsEnvBinDir dirStructure 241 | liftIO $ createDirectory $ hsEnvBinDir dirStructure 242 | 243 | -- initialize private GHC package database inside virtual environment 244 | initGhcDb :: Hsenv () 245 | initGhcDb = do 246 | dirStructure <- hseDirStructure 247 | info $ "Initializing GHC Package database at " ++ ghcPackagePath dirStructure 248 | out <- indentMessages $ insideGhcPkg ["--version"] Nothing 249 | case lastMay $ words out of 250 | Nothing -> throwError $ HsenvException $ "Couldn't extract ghc-pkg version number from: " ++ out 251 | Just versionString -> do 252 | indentMessages $ trace $ "Found version string: " ++ versionString 253 | version <- parseVersion versionString 254 | let ghc_6_12_1_version = Version [6,12,1] [] 255 | if version < ghc_6_12_1_version then do 256 | indentMessages $ debug "Detected GHC older than 6.12, initializing GHC_PACKAGE_PATH to file with '[]'" 257 | liftIO $ writeFile (ghcPackagePath dirStructure) "[]" 258 | else do 259 | _ <- indentMessages $ insideGhcPkg ["init", ghcPackagePath dirStructure] Nothing 260 | return () 261 | 262 | -- copy optional packages and don't fail completely if this copying fails 263 | -- some packages mail fail to copy and it's not fatal (e.g. older GHCs don't have haskell2010) 264 | transplantOptionalPackage :: String -> Hsenv () 265 | transplantOptionalPackage name = transplantPackage (PackageName name) `catchError` handler 266 | where handler e = do 267 | warning $ "Failed to copy optional package " ++ name ++ " from system's GHC: " 268 | indentMessages $ warning $ getExceptionMessage e 269 | 270 | -- copy base system 271 | -- base - needed for ghci and everything else 272 | -- Cabal - needed to install non-trivial cabal packages with cabal-install 273 | -- haskell98 - some packages need it but they don't specify it (seems it's an implicit dependancy) 274 | -- haskell2010 - maybe it's similar to haskell98? 275 | -- ghc and ghc-binary - two packages that are provided with GHC and cannot be installed any other way 276 | -- also include dependant packages of all the above 277 | -- when using GHC from tarball, just reuse its package database 278 | -- cannot do the same when using system's GHC, because there might be additional packages installed 279 | -- then it wouldn't be possible to work on them insie virtual environment 280 | copyBaseSystem :: Hsenv () 281 | copyBaseSystem = do 282 | info "Copying necessary packages from original GHC package database" 283 | indentMessages $ do 284 | ghc <- asks ghcSource 285 | case ghc of 286 | System -> do 287 | transplantPackage $ PackageName "base" 288 | transplantPackage $ PackageName "Cabal" 289 | mapM_ transplantOptionalPackage ["haskell98", "haskell2010", "ghc", "ghc-binary"] 290 | _ -> debug "Using external GHC - nothing to copy, Virtual environment will reuse GHC package database" 291 | 292 | installGhc :: Hsenv () 293 | installGhc = do 294 | info "Installing GHC" 295 | ghc <- asks ghcSource 296 | case ghc of 297 | System -> indentMessages $ debug "Using system version of GHC - nothing to install." 298 | Tarball tarballPath -> indentMessages $ installExternalGhc tarballPath 299 | Url url -> indentMessages $ installRemoteGhc url 300 | Release tag -> indentMessages $ installReleasedGhc tag 301 | 302 | installExternalGhc :: FilePath -> Hsenv () 303 | installExternalGhc tarballPath = do 304 | info $ "Installing GHC from " ++ tarballPath 305 | dirStructure <- hseDirStructure 306 | runInTmpDir $ do 307 | debug "Unpacking GHC tarball" 308 | _ <- indentMessages $ outsideProcess' "tar" [ "xf" 309 | , tarballPath 310 | , "--strip-components" 311 | , "1" 312 | ] 313 | cwd <- liftIO getCurrentDirectory 314 | let configureScript = cwd "configure" 315 | debug $ "Configuring GHC with prefix " ++ ghcDir dirStructure 316 | make <- asks makeCmd 317 | _ <- indentMessages $ outsideProcess' configureScript ["--prefix=" ++ ghcDir dirStructure] 318 | debug $ "Installing GHC with " ++ make ++ " install" 319 | _ <- indentMessages $ outsideProcess' make ["install"] 320 | return () 321 | 322 | -- Download a file over HTTP using streams, so it 323 | -- has constant memory allocation. 324 | downloadFile :: URL -> FilePath -> Hsenv () 325 | downloadFile url name = do 326 | m_ex <- liftIO $ get url $ \response inStream -> 327 | case getStatusCode response of 328 | 200 -> S.withFileAsOutput name (S.connect inStream) >> return Nothing 329 | code -> return $ Just $ HsenvException $ 330 | "Failed to download " 331 | ++ name 332 | ++ ": http response returned " 333 | ++ show code 334 | maybe (return ()) throwError m_ex 335 | 336 | installRemoteGhc :: String -> Hsenv () 337 | installRemoteGhc url = runInTmpDir $ do 338 | cwd <- liftIO getCurrentDirectory 339 | let tarball = cwd "tarball" 340 | debug $ "Downloading GHC from " ++ url 341 | downloadFile (C8.pack url) tarball 342 | installExternalGhc tarball 343 | 344 | installReleasedGhc :: String -> Hsenv () 345 | installReleasedGhc tag = do 346 | let url = "http://www.haskell.org/ghc/dist/" ++ tag ++ "/ghc-" ++ tag ++ "-" ++ platform ++ ".tar.bz2" 347 | installRemoteGhc url 348 | 349 | platform :: String 350 | platform = intercalate "-" [arch, if os == "darwin" then "apple" else "unknown", os] 351 | 352 | initDotHsenvDir :: Hsenv () 353 | initDotHsenvDir = do 354 | dir <- liftIO $ getAppUserDataDirectory "hsenv" 355 | liftIO $ createDirectoryIfMissing True dir 356 | --------------------------------------------------------------------------------