hsenv (empty) → 0.3
raw patch · 37 files changed
+2270/−0 lines, 37 filesdep +Cabaldep +basedep +bytestringsetup-changed
Dependencies added: Cabal, base, bytestring, directory, file-embed, filepath, mtl, process, safe, split, unix
Files
- LICENSE +30/−0
- README.md +178/−0
- Setup.hs +2/−0
- hsenv.cabal +142/−0
- hsenv.el +79/−0
- skeletons/activate +104/−0
- skeletons/cabal +47/−0
- skeletons/cabal_config +9/−0
- skeletons/ghc +23/−0
- skeletons/ghc-mod +23/−0
- skeletons/ghc-pkg +23/−0
- skeletons/ghci +23/−0
- skeletons/runghc +23/−0
- src/Actions.hs +309/−0
- src/Args.hs +103/−0
- src/MyMonad.hs +88/−0
- src/PackageManagement.hs +110/−0
- src/Paths.hs +59/−0
- src/Process.hs +143/−0
- src/SanityCheck.hs +64/−0
- src/Skeletons.hs +39/−0
- src/Types.hs +44/−0
- src/Util/Args.hs +12/−0
- src/Util/Args/ArgArrow.hs +39/−0
- src/Util/Args/ArgDescr.hs +27/−0
- src/Util/Args/Args.hs +86/−0
- src/Util/Args/GetOpt.hs +91/−0
- src/Util/Args/RawArgs.hs +40/−0
- src/Util/Args/Usage.hs +46/−0
- src/Util/Cabal.hs +39/−0
- src/Util/IO.hs +83/−0
- src/Util/List.hs +7/−0
- src/Util/StaticArrowT.hs +33/−0
- src/Util/String.hs +5/−0
- src/Util/Template.hs +22/−0
- src/Util/WordWrap.hs +27/−0
- src/hsenv.hs +48/−0
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c)2011, Bartosz Ćwikłowski++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the name of Bartosz Ćwikłowski nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ README.md view
@@ -0,0 +1,178 @@+Virtual Haskell Environment+===========================++What is it?+-----------+hsenv is a tool (inspired by Python's virtualenv)+to create isolated Haskell environments.+++What does it do?+----------------+It creates a sandboxed environment in a .hsenv_<ENVIRONMENT_NAME>/ sub-directory+of your project, which, when activated, allows you to use regular Haskell tools+(ghc, ghci, ghc-pkg, cabal) to manage your Haskell code and environment.+It's possible to create an environment, that uses different GHC version+than your currently installed. Very simple emacs integration mode is included.++Basic usage+-----------+First, choose a directory where you want to keep your+sandboxed Haskell environment, usually a good choice is a directory containing+your cabalized project (if you want to work on a few projects+(perhaps an app and its dependent library), just choose any of them,+it doesn't really matter). Enter that directory:++> cd ~/projects/foo++Next, create your new isolated Haskell environment+(this is a one time only (per environment) step):++> hsenv++Now, every time you want to use this environment, you have to activate it:++> source .hsenv_foo/bin/activate++That's it! Now it's possible to use all regular Haskell tools like usual,+but it won't affect your global/system's Haskell environment, and also+your per-user environment (from ~/.cabal and ~/.ghc) will stay the same.+All cabal-installed packages will be private to this environment,+and also the external environments (global and user) will not affect it+(this environment will only inherit very basic packages,+mostly ghc and Cabal and their deps).++When you're done working with this environment, enter command 'deactivate_hsenv',+or just close the current shell (with exit).++> deactivate_hsenv++Advanced usage+--------------+Here's the most advanced usage of hsenv. Let's say you want to:++* hack on json library+* do so comfortably+* use your own version of parsec library+* and do all this using nightly version of GHC++First, download binary distribution of GHC for your platform+(e.g. ghc-7.3.20111105-i386-unknown-linux.tar.bz2).++Create a directory for you environment:++> mkdir /tmp/test; cd /tmp/test++Then, create a new environment using that GHC:++> hsenv --ghc=/path/to/ghc-7.3.20111105-i386-unknown-linux.tar.bz2++Activate it:++> source .hsenv_test/bin/activate++Download a copy of json library and your private version of parsec:++> darcs get http://patch-tag.com/r/Paczesiowa/parsec; cabal unpack json++Install parsec:++> cd parsec2; cabal install++Install the rest of json deps:++> cd ../json-0.5; cabal install --only-dependencies++Now, let's say you want to hack on Parsec module of json library.+Open it in emacs:++> emacsclient Text/JSON/Parsec.hs++Activate the virtual environment (hsenv must be required earlier):++> M-x hsenv-activate <RET> /tmp/test/ <RET>++Edit some code and load it in ghci using 'C-c C-l'. If it type checks,+you can play around with the code using nightly version of ghci running+in your virtual environment. When you're happy with the code, exit emacs+and install your edited json library:++> cabal install++And that's it.++Misc+----+hsenv has been tested on i386 Linux and FreeBSD systems,+but it should work on any Posix platform. External (from tarball) GHC feature+requires binary GHC distribution compiled for your platform,+that can be extracted with tar and installed with+"./configure --prefix=PATH; make install".++FAQ+---+Q: Can I use it together with tools like cabal-dev or capri? +A: No. All these tools work more or less the same (wrapping cabal command,+ setting GHC_PACKAGE_PATH env variable), so something will probably break.++Q: Using GHC from tarball fails, when using FreeBSD with a bunch of make tool+ gibberish. What do I do? +A: Try '--make-cmd=gmake' switch.++Q: Can I use hsenv inside hsenv? +A: No. It may be supported in future versions.++Q: Does it work on x64 systems? +A: It hasn't been tested, but there's no reason why it shouldn't.++Q: Will it work on Mac? +A: I doubt it. It should be easy to make it work there with system's GHC,+ Using GHC from tarball will be probably harder. I don't have any mac+ machines, so you're on your own, but patches/ideas/questions are welcome.++Q: Will it work on Windows? +A: I really doubt it would even compile. I don't have access to any windows+ machines, so you're on your own, but patches/ideas/questions are welcome.+ Maybe it would work on cygwin.++Q: Does it require bash? +A: No, it should work with any POSIX-compliant shell. It's been tested with+ bash, bash --posix, dash, zsh and ksh.++Q: Can I use it with a different haskell package repository than hackage? +A: Yes, just adjust the url in .hsenv_<ENVIRONMENT_NAME>/cabal/config file.++Q: How do I remove the whole virtual environment? +A: If it's activated - 'deactivate_hsenv' it. Then, delete+ the .hsenv_<ENVIRONMENT_NAME>/ directory.++Q: Is every environment completely separate from other environments and+ the system environment? +A: Yes. The only (minor) exception is ghci history - there's only one+ per user history file. Also, if you alter your system's GHC, then+ virtual environments using system's GHC copy will probably break.+ Virtual environments using GHC from a tarball should continue to work.++Q: Can I use multiple environments in the same directory (e.g. to test+ my project against different ghc versions)? +A: Yes, just use different names for all the environments.++Q: Can I share one cabalized project directory among multiple environments+ (e.g. build cabalized project in the same dir using different environments)? +A: Yes. hsenv also overrides cabal with a wrapper, that will force using different+ builddirs, so there shouldn't be even any recompilation between different environments.++Q: Is it possible to activate an environment upon entering its directory? +A: Yes, if you really know what you're doing. Here's a snippet for bash:++ function precmd() {+ if [[ -z $HSENV ]]; then+ NUMBER_OF_ENVS=$(find . -maxdepth 1 -type d -name ".hsenv_*" | wc -l)+ case ${NUMBER_OF_ENVS} in+ "0") ;;+ "1") source .hsenv_*/bin/activate;;+ *) echo multiple environments, manual activaton required;;+ esac+ fi+ }+ export PROMPT_COMMAND=precmd
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ hsenv.cabal view
@@ -0,0 +1,142 @@+Name: hsenv++Version: 0.3++Synopsis: Virtual Haskell Environment builder++Description: hsenv is a tool (inspired by Python's virtualenv) to create isolated Haskell environments.+ .+ It creates a sandboxed environment in a .hsenv_<ENVIRONMENT_NAME>/ directory, which, when activated,+ allows you to use regular Haskell tools (ghc, ghci, ghc-pkg, cabal) to manage your Haskell+ code and environment. It's possible to create an environment, that uses a different GHC version+ than your currently installed system GHC. hsenv is supposed to be easier to learn (and use) than+ similar packages (like cabal-dev or capri).+ .+ Basic usage.+ .+ First, choose a directory where you want to keep your sandboxed Haskell environment,+ usually a good choice is a directory containing your cabalized project (if you want to work+ on a few projects (perhaps an app and its dependent library), just choose any of them,+ it doesn't really matter). Enter that directory:+ .+ > cd ~/projects/foo+ .+ Next, create your new isolated Haskell environment (this is a one time only (per environment) step):+ .+ > hsenv+ .+ Now, every time you want to use this enviroment, you have to activate it:+ .+ > source .hsenv_foo/bin/activate+ .+ That's it! Now it's possible to use all regular Haskell tools like usual, but it won't affect+ your global/system's Haskell environment, and also your per-user environment (from ~/.cabal and+ ~/.ghc) will stay the same. All cabal-installed packages will be private to this environment,+ and also the external environments (global and user) will not affect it (this environment+ will only inherit very basic packages - mostly ghc and Cabal and their deps).+ .+ When you're done working with this environment, enter command 'deactivate_hsenv',+ or just close the current shell (with exit).+ .+ > deactivate_hsenv+ .+ Advanced usage.+ .+ The only advanced usage is using different GHC version. This can be useful to test your code+ against different GHC version (even against nightly builds).+ .+ First, download binary distribution of GHC for your platform+ (e.g. ghc-7.0.4-i386-unknown-linux.tar.bz2), then create a new environment using that GHC+ .+ > hsenv --ghc=/path/to/ghc_something.tar.bz2+ .+ Then, proceed (with [de]activation) as in basic case.+ .+ Misc.+ .+ hsenv has been tested on i386 Linux systems, but it should work on any Posix platform.+ External (from tarball) GHC feature requires binary GHC distribution compiled for your platform,+ that can be extracted with tar and installed with "./configure --prefix=PATH; make install".+ .+ For more info please consult "hsenv --help" or the attached README file.++Homepage: https://github.com/tmhedberg/hsenv++License: BSD3++License-file: LICENSE++Author: Bartosz Ćwikłowski++Maintainer: Taylor Hedberg <t@tmh.cc>++Copyright: (c) 2011 Bartosz Ćwikłowski++Category: Development++Build-type: Simple++Stability: provisional++Bug-reports: https://github.com/tmhedberg/hsenv/issues++Package-url: http://hackage.haskell.org/package/hsenv++Tested-with: GHC == 6.12.3, GHC == 7.0.4, GHC == 7.4.2, GHC == 7.6.1++Data-files: hsenv.el, README.md++Extra-source-files: skeletons/activate, skeletons/cabal, skeletons/cabal_config, skeletons/ghc, skeletons/ghc-mod,+ skeletons/ghc-pkg, skeletons/ghci, skeletons/runghc++Cabal-version: >=1.6++Executable hsenv++ Main-is: hsenv.hs++ Hs-source-dirs: src++ cpp-options: -Dcabal++ Ghc-options: -threaded -Wall++ Build-depends: base >= 4.2.0.0 && < 4.7+ , process >= 1.0.1.2 && < 1.2+ , filepath >= 1.1.0.3 && < 1.4+ , directory >= 1.0.1.0 && < 1.3+ , Cabal >= 1.8.0.6 && < 1.17+ , mtl >= 1.1.0.2 && < 2.2+ , bytestring >= 0.9.1.7 && < 0.11+ , file-embed >= 0.0.4.1 && < 0.1+ , split >= 0.1.4 && < 0.3+ , safe >= 0.3 && < 0.4+ , unix >= 2.0 && < 2.7++ Other-modules: Util.Cabal+ , Util.Args+ , Util.Args.Args+ , Util.Args.ArgArrow+ , Util.Args.ArgDescr+ , Util.Args.RawArgs+ , Util.Args.GetOpt+ , Util.Args.Usage+ , Util.List+ , Util.StaticArrowT+ , Util.String+ , Util.Template+ , Util.IO+ , Util.WordWrap+ , Skeletons+ , Types+ , MyMonad+ , Args+ , Paths+ , SanityCheck+ , Process+ , PackageManagement+ , Actions++Source-repository head+ Type: git+ Location: git://github.com/tmhedberg/hsenv.git
+ hsenv.el view
@@ -0,0 +1,79 @@+(defvar hsenv-active-environment nil)+(defconst hsenv-path-prepend-file "path_var_prependix")+(defconst hsenv-ghc-package-path-file "ghc_package_path_var")++(defun hsenv-valid-dirp (hsenv-dir)+ (let ((valid (and (file-accessible-directory-p hsenv-dir)+ (file-readable-p (concat hsenv-dir hsenv-path-prepend-file))+ (file-readable-p (concat hsenv-dir hsenv-ghc-package-path-file)))))+ (when (not valid)+ (message "The environment you provided is not a valid hsenv directory (%s)." hsenv-dir))+ valid))++(defun hsenv-is-not-active ()+ (let ((is-not-active (not hsenv-active-environment)))+ (when (not is-not-active)+ (message "An hsenv is already activated (%s)." (assoc-default 'dir hsenv-active-environment)))+ is-not-active))++(defun hsenv-is-active ()+ (let ((is-active hsenv-active-environment))+ (when (not is-active)+ (message "No hsenv currently activated."))+ is-active))++(defun hsenv-read-file-content (hsenv-dir file)+ (with-temp-buffer+ (insert-file-contents (concat hsenv-dir file))+ (buffer-string)))++(defun hsenv-activate-environment (hsenv-dir)+ "Activate the Virtual Haskell Environment in directory HSENV-DIR"+ (when (and (hsenv-valid-dirp hsenv-dir)+ (hsenv-is-not-active))+ ; Create an hsenv active environment and backup paths+ (setq hsenv-active-environment (list `(path-backup . ,(getenv "PATH"))+ `(exec-path-backup . ,exec-path)+ `(dir . ,hsenv-dir)))+ ; Prepend paths+ (let* ((path-prepend (hsenv-read-file-content hsenv-dir hsenv-path-prepend-file)))+ (setenv "PATH" (concat path-prepend ":" (getenv "PATH")))+ (setq exec-path (append (split-string path-prepend ":") exec-path)))+ ; Set ghc-package+ (setenv "GHC_PACKAGE_PATH" (hsenv-read-file-content hsenv-dir hsenv-ghc-package-path-file))))++(defun hsenv-deactivate ()+ "Deactivate the Virtual Haskell Environment"+ (interactive)+ (when (hsenv-is-active)+ ; Restore paths+ (setenv "PATH" (assoc-default 'path-backup hsenv-active-environment))+ (setq exec-path (assoc-default 'exec-path-backup hsenv-active-environment))+ ; Destroy the hsenv active environment+ (setq hsenv-active-environment nil)))++(defun hsenv-activate-dir (dir)+ (let ((environments (hsenv-list-environments dir)))+ (if (null environments)+ (message "Directory %s does not contain any hsenv." dir)+ (let* ((env-name (if (= 1 (length environments))+ (car environments)+ (completing-read "Environment:" environments)))+ (hsenv-dir-name (concat dir ".hsenv_" env-name))+ (hsenv-dir (file-name-as-directory hsenv-dir-name)))+ (hsenv-activate-environment hsenv-dir)))))++(defun hsenv-list-environments (dir)+ (let ((hsenv-dirs (file-expand-wildcards (concat dir ".hsenv_*"))))+ (mapcar (lambda (hsenv-dir) (substring hsenv-dir (+ 7 (length dir)))) hsenv-dirs)))+++(defun hsenv-activate (&optional select-dir)+ "Activate a Virtual Haskell Environment"+ (interactive "P")+ (if (or select-dir+ (null (hsenv-list-environments default-directory)))+ (hsenv-activate-dir (read-directory-name "Directory:"))+ (hsenv-activate-dir default-directory)))++(provide 'hsenv)
+ skeletons/activate view
@@ -0,0 +1,104 @@+if [ -n "${HSENV}" ]; then+ if [ "<HSENV>" = "${HSENV}" -a "<HSENV_NAME>" = "${HSENV_NAME}" ]; then+ echo "${HSENV_NAME} Virtual Haskell Environment is already active."+ else+ echo "There is already ${HSENV_NAME} Virtual Haskell Environment activated."+ echo "(at ${HSENV})"+ echo "Deactivate it first (using command 'deactivate_hsenv'), to activate"+ echo "<HSENV_NAME> environment."+ fi+ return 1+fi++export HSENV="<HSENV>"+export HSENV_NAME="<HSENV_NAME>"++echo "Activating ${HSENV_NAME} Virtual Haskell Environment (at ${HSENV})."+echo ""+echo "Use regular Haskell tools (ghc, ghci, ghc-pkg, cabal) to manage your Haskell environment."+echo ""+echo "To exit from this virtual environment, enter command 'deactivate_hsenv'."++export "HSENV_PATH_BACKUP"="${PATH}"+export "HSENV_PS1_BACKUP"="${PS1}"++deactivate_hsenv() {+ echo "Deactivating ${HSENV_NAME} Virtual Haskell Environment (at ${HSENV})."+ echo "Restoring previous environment settings."++ export "PATH"="${HSENV_PATH_BACKUP}"+ unset -v "HSENV_PATH_BACKUP"+ export "PS1"="${HSENV_PS1_BACKUP}"+ unset -v "HSENV_PS1_BACKUP"++ unset -v PACKAGE_DB_FOR_CABAL+ unset -v PACKAGE_DB_FOR_GHC_PKG+ unset -v PACKAGE_DB_FOR_GHC+ unset -v HSENV+ unset -v HSENV_NAME+ unset -v GHC_PACKAGE_PATH+ unset -f deactivate_hsenv++ if [ -n "$BASH" -o -n "$ZSH_VERSION" ]; then+ hash -r+ fi+}++PATH_PREPENDIX="$(cat <HSENV_DIR>/path_var_prependix)"+export PATH="${PATH_PREPENDIX}:${PATH}"+unset -v PATH_PREPENDIX++unset -v PACKAGE_DB_FOR_GHC+ghc --version > /dev/null+if [ "$?" -ne 0 ]; then+ echo "Failed to get ghc version. Deactivating environment..."+ deactivate_hsenv+ exit 1+fi++# To compare version numbers as ints, split at dots, check them all.+GHC_VERSION_OUTPUT="$(ghc --version)"+GHC_VERSION_NUMBER="$(echo $GHC_VERSION_OUTPUT | sed 's/.* //' | tr '.' ' ')"++item=1+for check_num in 7 6 1+do+ cur_num=$(echo $GHC_VERSION_NUMBER | awk "{ print \$$item; }")++ if [ "$cur_num" -lt "$check_num" ]+ then+ PKG_DB_OPT_SUFFIX="conf"+ break+ fi+ item=$(expr $item + 1)+done++# If it's still unset, we're >= 7.6.1+if [ -z "$PKG_DB_OPT_SUFFIX" ]+then+ PKG_DB_OPT_SUFFIX="db"+fi++GHC_PACKAGE_PATH_REPLACEMENT="$(cat <HSENV_DIR>/ghc_package_path_var | sed -r -e 's/^/:/' -e 's/::*/:/g' -e 's/:\s*$//')"++replace_pkg () {+ replacement=$1++ echo "$GHC_PACKAGE_PATH_REPLACEMENT" | sed -e "s/:/ $replacement/g"+}++export PACKAGE_DB_FOR_CABAL="$(replace_pkg '--package-db=')"+export PACKAGE_DB_FOR_GHC_PKG=" --no-user-package-${PKG_DB_OPT_SUFFIX} $(replace_pkg --package-${PKG_DB_OPT_SUFFIX}=)"+export PACKAGE_DB_FOR_GHC=" -no-user-package-${PKG_DB_OPT_SUFFIX} $(replace_pkg -package-${PKG_DB_OPT_SUFFIX}=)"+export PACKAGE_DB_FOR_GHC_MOD=" -g -no-user-package-${PKG_DB_OPT_SUFFIX} $(replace_pkg '-g -package-'${PKG_DB_OPT_SUFFIX}=)"++export PS1="(${HSENV_NAME})${PS1}"++unset -v GHC_VERSION_OUTPUT+unset -v GHC_VERSION_NUMBER+unset -v PKG_DB_OPT_SUFFIX+unset -v GHC_PACKAGE_PATH_REPLACEMENT++if [ -n "$BASH" -o -n "$ZSH_VERSION" ]; then+ hash -r+fi
+ skeletons/cabal view
@@ -0,0 +1,47 @@+#!/bin/sh++PATH_ELEMS="$(echo ${PATH} | tr -s ':' '\n')"++ORIG_CABAL_BINARY=""++for PATH_ELEM in ${PATH_ELEMS}; do+ CABAL_CANDIDATE="${PATH_ELEM}/cabal"+ if command -v "${CABAL_CANDIDATE}" > /dev/null 2> /dev/null; then+ if [ "${0}" != "${CABAL_CANDIDATE}" ]; then+ if [ -z "${ORIG_CABAL_BINARY}" ]; then+ ORIG_CABAL_BINARY="${CABAL_CANDIDATE}"+ fi+ fi+ fi+done++if [ -z "${ORIG_CABAL_BINARY}" ]; then+ echo "cabal wrapper: Couldn't find real cabal program"+ exit 1+fi++CABAL_CONFIG="<CABAL_CONFIG>"++CABAL_BUILDDIR_ARG=""++CABAL_BUILDABLE_COMMANDS="build clean configure copy haddock hscolour install register sdist test upgrade"++CABAL_COMMAND="$(echo ${@} | tr -s ' ' '\n' | grep -E '[a-z]' | grep -Ev '^-' | head -n 1)"++for CABAL_BUILDABLE_COMMAND in ${CABAL_BUILDABLE_COMMANDS}; do+ if [ "${CABAL_BUILDABLE_COMMAND}" = "${CABAL_COMMAND}" ]; then+ CABAL_BUILDDIR_ARG="--builddir=dist_<HSENV_NAME>"+ fi+done++CABAL_CONFIGURE_COMMANDS="configure install upgrade"++for CABAL_CONFIGURE_COMMAND in ${CABAL_CONFIGURE_COMMANDS}; do+ if [ "${CABAL_CONFIGURE_COMMAND}" = "${CABAL_COMMAND}" ]; then+ CABAL_BUILDDIR_ARG="${CABAL_BUILDDIR_ARG} ${PACKAGE_DB_FOR_CABAL}"+ fi+done++exec "${ORIG_CABAL_BINARY}" \+ --config-file="${CABAL_CONFIG}" \+ ${CABAL_BUILDDIR_ARG} "${@}"
+ skeletons/cabal_config view
@@ -0,0 +1,9 @@+remote-repo: hackage.haskell.org:http://hackage.haskell.org/packages/archive+remote-repo-cache: <HACKAGE_CACHE>+logs-dir: <CABAL_DIR>/logs+world-file: <CABAL_DIR>/world+package-db: <GHC_PACKAGE_PATH>+build-summary: <CABAL_DIR>/logs/build.log+remote-build-reporting: anonymous+install-dirs user+ prefix: <CABAL_DIR>
+ skeletons/ghc view
@@ -0,0 +1,23 @@+#!/bin/sh++PATH_ELEMS="$(echo ${PATH} | tr -s ':' '\n')"++ORIG_GHC_BINARY=""++for PATH_ELEM in ${PATH_ELEMS}; do+ GHC_CANDIDATE="${PATH_ELEM}/ghc"+ if command -v "${GHC_CANDIDATE}" > /dev/null 2> /dev/null; then+ if [ "${0}" != "${GHC_CANDIDATE}" ]; then+ if [ -z "${ORIG_GHC_BINARY}" ]; then+ ORIG_GHC_BINARY="${GHC_CANDIDATE}"+ fi+ fi+ fi+done++if [ -z "${ORIG_GHC_BINARY}" ]; then+ echo "ghc wrapper: Couldn't find real ghc program"+ exit 1+fi++exec "$ORIG_GHC_BINARY" ${PACKAGE_DB_FOR_GHC} "$@"
+ skeletons/ghc-mod view
@@ -0,0 +1,23 @@+#!/bin/sh++PATH_ELEMS="$(echo ${PATH} | tr -s ':' '\n')"++ORIG_GHC_MOD_BINARY=""++for PATH_ELEM in ${PATH_ELEMS}; do+ GHC_MOD_CANDIDATE="${PATH_ELEM}/ghc-mod"+ if command -v "${GHC_MOD_CANDIDATE}" > /dev/null 2> /dev/null; then+ if [ "${0}" != "${GHC_MOD_CANDIDATE}" ]; then+ if [ -z "${ORIG_GHC_MOD_BINARY}" ]; then+ ORIG_GHC_MOD_BINARY="${GHC_MOD_CANDIDATE}"+ fi+ fi+ fi+done++if [ -z "${ORIG_GHC_MOD_BINARY}" ]; then+ echo "ghc-mod wrapper: Couldn't find real ghc-mod program"+ exit 1+fi++exec "$ORIG_GHC_MOD_BINARY" ${PACKAGE_DB_FOR_GHC_MOD} "$@"
+ skeletons/ghc-pkg view
@@ -0,0 +1,23 @@+#!/bin/sh++PATH_ELEMS="$(echo ${PATH} | tr -s ':' '\n')"++ORIG_GHC_PKG_BINARY=""++for PATH_ELEM in ${PATH_ELEMS}; do+ GHC_PKG_CANDIDATE="${PATH_ELEM}/ghc-pkg"+ if command -v "${GHC_PKG_CANDIDATE}" > /dev/null 2> /dev/null; then+ if [ "${0}" != "${GHC_PKG_CANDIDATE}" ]; then+ if [ -z "${ORIG_GHC_PKG_BINARY}" ]; then+ ORIG_GHC_PKG_BINARY="${GHC_PKG_CANDIDATE}"+ fi+ fi+ fi+done++if [ -z "${ORIG_GHC_PKG_BINARY}" ]; then+ echo "ghc-pkg wrapper: Couldn't find real ghc-pkg program"+ exit 1+fi++exec "$ORIG_GHC_PKG_BINARY" ${PACKAGE_DB_FOR_GHC_PKG} "$@"
+ skeletons/ghci view
@@ -0,0 +1,23 @@+#!/bin/sh++PATH_ELEMS="$(echo ${PATH} | tr -s ':' '\n')"++ORIG_GHCI_BINARY=""++for PATH_ELEM in ${PATH_ELEMS}; do+ GHCI_CANDIDATE="${PATH_ELEM}/ghci"+ if command -v "${GHCI_CANDIDATE}" > /dev/null 2> /dev/null; then+ if [ "${0}" != "${GHCI_CANDIDATE}" ]; then+ if [ -z "${ORIG_GHCI_BINARY}" ]; then+ ORIG_GHCI_BINARY="${GHCI_CANDIDATE}"+ fi+ fi+ fi+done++if [ -z "${ORIG_GHCI_BINARY}" ]; then+ echo "ghci wrapper: Couldn't find real ghci program"+ exit 1+fi++exec "$ORIG_GHCI_BINARY" ${PACKAGE_DB_FOR_GHC} "$@"
+ skeletons/runghc view
@@ -0,0 +1,23 @@+#!/bin/sh++PATH_ELEMS="$(echo ${PATH} | tr -s ':' '\n')"++ORIG_RUNGHC_BINARY=""++for PATH_ELEM in ${PATH_ELEMS}; do+ RUNGHC_CANDIDATE="${PATH_ELEM}/runghc"+ if command -v "${RUNGHC_CANDIDATE}" > /dev/null 2> /dev/null; then+ if [ "${0}" != "${RUNGHC_CANDIDATE}" ]; then+ if [ -z "${ORIG_RUNGHC_BINARY}" ]; then+ ORIG_RUNGHC_BINARY="${RUNGHC_CANDIDATE}"+ fi+ fi+ fi+done++if [ -z "${ORIG_RUNGHC_BINARY}" ]; then+ echo "runghc wrapper: Couldn't find real runghc program"+ exit 1+fi++exec "$ORIG_RUNGHC_BINARY" ${PACKAGE_DB_FOR_GHC} "$@"
+ src/Actions.hs view
@@ -0,0 +1,309 @@+module Actions ( cabalUpdate+ , installCabalConfig+ , installCabalWrapper+ , installActivateScript+ , installSimpleWrappers+ , installProgSymlinks+ , symlinkToSkeleton+ , copyBaseSystem+ , initGhcDb+ , installGhc+ , createDirStructure+ ) where++import Control.Monad+import System.Directory (setCurrentDirectory, getCurrentDirectory, createDirectory, removeDirectoryRecursive, getAppUserDataDirectory, doesFileExist, findExecutable)+import System.FilePath ((</>))+import System.Posix hiding (createDirectory, version)+import Distribution.Version (Version (..))+import Distribution.Package (PackageName(..))+import Safe (lastMay)+import Data.List (intercalate)+import Data.Maybe++import MyMonad+import Types+import Paths+import PackageManagement+import Process+import Util.Template (substs)+import Util.IO (makeExecutable, createTemporaryDirectory)+import Skeletons++-- update cabal package info inside Virtual Haskell Environment+cabalUpdate :: MyMonad ()+cabalUpdate = do+ noSharingFlag <- asks noSharing+ if noSharingFlag then do+ debug "Sharing user-wide ~/.cabal/packages disabled"+ cabalUpdate'+ else do+ debug "Sharing user-wide ~/.cabal/packages enabled, checking if data is already downloaded"+ cabalInstallDir <- liftIO $ getAppUserDataDirectory "cabal"+ let hackageData = foldl (</>) cabalInstallDir [ "packages"+ , "hackage.haskell.org"+ , "00-index.tar"+ ]+ dataExists <- liftIO $ doesFileExist hackageData+ if dataExists then do+ info "Skipping 'cabal update' step, Hackage download cache already downloaded"+ info " to ~/.cabal/packages/. You can update it manually with 'cabal update'"+ info " (from inside or outside the virtual environment)."+ else do+ debug "No user-wide Hackage cache data downloaded"+ cabalUpdate'+ where cabalUpdate' = do+ cabalConfig <- cabalConfigLocation+ info "Updating cabal package database inside Virtual Haskell Environment."+ _ <- indentMessages $ insideProcess "cabal" ["--config-file=" ++ cabalConfig, "update"] Nothing+ return ()+++-- install cabal wrapper (in bin/ directory) inside virtual environment dir structure+installCabalWrapper :: MyMonad ()+installCabalWrapper = do+ cabalConfig <- cabalConfigLocation+ dirStructure <- hseDirStructure+ hsEnvName' <- asks hsEnvName+ let cabalWrapper = hsEnvBinDir dirStructure </> "cabal"+ info $ concat [ "Installing cabal wrapper using "+ , cabalConfig+ , " at "+ , cabalWrapper+ ]+ let cabalWrapperContents = substs [ ("<CABAL_CONFIG>", cabalConfig)+ , ("<HSENV_NAME>", hsEnvName')] cabalWrapperSkel+ indentMessages $ do+ trace "cabal wrapper contents:"+ indentMessages $ mapM_ trace $ lines cabalWrapperContents+ liftIO $ writeFile cabalWrapper cabalWrapperContents+ liftIO $ makeExecutable cabalWrapper++installActivateScriptSupportFiles :: MyMonad ()+installActivateScriptSupportFiles = do+ debug "installing supporting files"+ dirStructure <- hseDirStructure+ ghc <- asks ghcSource+ indentMessages $ do+ let pathVarPrependixLocation = hsEnvDir dirStructure </> "path_var_prependix"+ pathVarElems =+ case ghc of+ System -> [hsEnvBinDir dirStructure, cabalBinDir dirStructure]+ Tarball _ -> [ hsEnvBinDir dirStructure+ , cabalBinDir dirStructure+ , ghcBinDir dirStructure+ ]+ pathVarPrependix = intercalate ":" pathVarElems+ debug $ "installing path_var_prependix file to " ++ pathVarPrependixLocation+ indentMessages $ trace $ "path_var_prependix contents: " ++ pathVarPrependix+ liftIO $ writeFile pathVarPrependixLocation pathVarPrependix+ ghcPkgDbPath <- indentMessages ghcPkgDbPathLocation+ let ghcPackagePathVarLocation = hsEnvDir dirStructure </> "ghc_package_path_var"+ ghcPackagePathVar = ghcPkgDbPath+ debug $ "installing ghc_package_path_var file to " ++ ghcPackagePathVarLocation+ indentMessages $ trace $ "path_var_prependix contents: " ++ ghcPackagePathVar+ liftIO $ writeFile ghcPackagePathVarLocation ghcPackagePathVar++-- install activate script (in bin/ directory) inside virtual environment dir structure+installActivateScript :: MyMonad ()+installActivateScript = do+ info "Installing activate script"+ hsEnvName' <- asks hsEnvName+ dirStructure <- hseDirStructure+ ghcPkgDbPath <- indentMessages ghcPkgDbPathLocation+ let activateScript = hsEnvBinDir dirStructure </> "activate"+ indentMessages $ debug $ "using location: " ++ activateScript+ let activateScriptContents = substs [ ("<HSENV_NAME>", hsEnvName')+ , ("<HSENV_DIR>", hsEnvDir dirStructure)+ , ("<HSENV>", hsEnv dirStructure)+ , ("<GHC_PACKAGE_PATH>", ghcPkgDbPath)+ , ("<HSENV_BIN_DIR>", hsEnvBinDir dirStructure)+ , ("<CABAL_BIN_DIR>", cabalBinDir dirStructure)+ , ("<GHC_BIN_DIR>", ghcBinDir dirStructure)+ ] activateSkel+ indentMessages $ do+ trace "activate script contents:"+ indentMessages $ mapM_ trace $ lines activateScriptContents+ liftIO $ writeFile activateScript activateScriptContents+ indentMessages installActivateScriptSupportFiles++-- install cabal's config file (in cabal/ directory) inside virtual environment dir structure+installCabalConfig :: MyMonad ()+installCabalConfig = do+ cabalConfig <- cabalConfigLocation+ dirStructure <- hseDirStructure+ noSharingFlag <- asks noSharing+ hackageCache <- indentMessages $+ if noSharingFlag then do+ info "Using private Hackage download cache directory"+ return $ cabalDir dirStructure </> "packages"+ else do+ info "Using user-wide (~/.cabal/packages) Hackage download cache directory"+ cabalInstallDir <- liftIO $ getAppUserDataDirectory "cabal"+ return $ cabalInstallDir </> "packages"+ info $ "Installing cabal config at " ++ cabalConfig+ let cabalConfigContents = substs [ ("<GHC_PACKAGE_PATH>", ghcPackagePath dirStructure)+ , ("<CABAL_DIR>", cabalDir dirStructure)+ , ("<HACKAGE_CACHE>", hackageCache)+ ] cabalConfigSkel+ indentMessages $ do+ trace "cabal config contents:"+ indentMessages $ mapM_ trace $ lines cabalConfigContents+ liftIO $ writeFile cabalConfig cabalConfigContents++installSimpleWrappers :: MyMonad ()+installSimpleWrappers = mapM_ installSimpleWrapper simpleWrappers++installSimpleWrapper :: (String, String) -> MyMonad ()+installSimpleWrapper (targetFilename, skeleton) = do+ ghcPkgDbPath <- indentMessages ghcPkgDbPathLocation+ dirStructure <- hseDirStructure+ let ghcWrapperContents =+ substs [("<GHC_PACKAGE_PATH>", ghcPkgDbPath)] skeleton+ ghcWrapper = hsEnvBinDir dirStructure </> targetFilename+ liftIO $ writeFile ghcWrapper ghcWrapperContents+ liftIO $ makeExecutable ghcWrapper++installProgSymlinks :: MyMonad ()+installProgSymlinks = mapM_ installSymlink extraProgs++extraProgs :: [String]+extraProgs = [ "alex"+ , "ar"+ , "c2hs"+ , "cpphs"+ , "ffihugs"+ , "gcc"+ , "greencard"+ , "haddock"+ , "happy"+ , "hmake"+ , "hpc"+ , "hsc2hs"+ , "hscolour"+ , "hugs"+ , "jhc"+ , "ld"+ , "lhc"+ , "lhc-pkg"+ , "nhc98"+ , "pkg-config"+ , "ranlib"+ , "strip"+ , "tar"+ , "uhc"+ ]++installSymlink :: String -> MyMonad ()+installSymlink prog = do+ dirStructure <- hseDirStructure+ ghcSourceOpt <- asks ghcSource+ mPrivateLoc <- case ghcSourceOpt of+ System -> return Nothing+ _ -> liftIO $ findExecutable $ ghcDir dirStructure </> "bin" </> prog+ mSystemLoc <- liftIO $ findExecutable prog+ let mProgLoc = mPrivateLoc `mplus` mSystemLoc+ when (isJust mProgLoc) $ do+ let Just progLoc = mProgLoc+ liftIO $ createSymbolicLink progLoc $ hsEnvBinDir dirStructure </> prog++-- | Install a symbolic link to a skeleton script in hsenv's bin directory+symlinkToSkeleton :: String -- ^ Name of skeleton+ -> String -- ^ Name of link+ -> MyMonad ()+symlinkToSkeleton skel link = do+ dirStructure <- hseDirStructure+ let prependBinDir = (hsEnvBinDir dirStructure </>)+ liftIO $ createSymbolicLink (prependBinDir skel) (prependBinDir link)++createDirStructure :: MyMonad ()+createDirStructure = do+ dirStructure <- hseDirStructure+ info "Creating Virtual Haskell directory structure"+ indentMessages $ do+ debug $ "hsenv directory: " ++ hsEnvDir dirStructure+ liftIO $ createDirectory $ hsEnvDir dirStructure+ debug $ "cabal directory: " ++ cabalDir dirStructure+ liftIO $ createDirectory $ cabalDir dirStructure+ debug $ "hsenv bin directory: " ++ hsEnvBinDir dirStructure+ liftIO $ createDirectory $ hsEnvBinDir dirStructure++-- initialize private GHC package database inside virtual environment+initGhcDb :: MyMonad ()+initGhcDb = do+ dirStructure <- hseDirStructure+ info $ "Initializing GHC Package database at " ++ ghcPackagePath dirStructure+ out <- indentMessages $ outsideGhcPkg ["--version"]+ case lastMay $ words out of+ Nothing -> throwError $ MyException $ "Couldn't extract ghc-pkg version number from: " ++ out+ Just versionString -> do+ indentMessages $ trace $ "Found version string: " ++ versionString+ version <- parseVersion versionString+ let ghc_6_12_1_version = Version [6,12,1] []+ if version < ghc_6_12_1_version then do+ indentMessages $ debug "Detected GHC older than 6.12, initializing GHC_PACKAGE_PATH to file with '[]'"+ liftIO $ writeFile (ghcPackagePath dirStructure) "[]"+ else do+ _ <- indentMessages $ outsideGhcPkg ["init", ghcPackagePath dirStructure]+ return ()++-- copy optional packages and don't fail completely if this copying fails+-- some packages mail fail to copy and it's not fatal (e.g. older GHCs don't have haskell2010)+transplantOptionalPackage :: String -> MyMonad ()+transplantOptionalPackage name = transplantPackage (PackageName name) `catchError` handler+ where handler e = do+ warning $ "Failed to copy optional package " ++ name ++ " from system's GHC: "+ indentMessages $ warning $ getExceptionMessage e++-- copy base system+-- base - needed for ghci and everything else+-- Cabal - needed to install non-trivial cabal packages with cabal-install+-- haskell98 - some packages need it but they don't specify it (seems it's an implicit dependancy)+-- haskell2010 - maybe it's similar to haskell98?+-- ghc and ghc-binary - two packages that are provided with GHC and cannot be installed any other way+-- also include dependant packages of all the above+-- when using GHC from tarball, just reuse its package database+-- cannot do the same when using system's GHC, because there might be additional packages installed+-- then it wouldn't be possible to work on them insie virtual environment+copyBaseSystem :: MyMonad ()+copyBaseSystem = do+ info "Copying necessary packages from original GHC package database"+ indentMessages $ do+ ghc <- asks ghcSource+ case ghc of+ System -> do+ transplantPackage $ PackageName "base"+ transplantPackage $ PackageName "Cabal"+ mapM_ transplantOptionalPackage ["haskell98", "haskell2010", "ghc", "ghc-binary"]+ Tarball _ ->+ debug "Using external GHC - nothing to copy, Virtual environment will reuse GHC package database"++installGhc :: MyMonad ()+installGhc = do+ info "Installing GHC"+ ghc <- asks ghcSource+ case ghc of+ System -> indentMessages $ debug "Using system version of GHC - nothing to install."+ Tarball tarballPath -> indentMessages $ installExternalGhc tarballPath++installExternalGhc :: FilePath -> MyMonad ()+installExternalGhc tarballPath = do+ info $ "Installing GHC from " ++ tarballPath+ indentMessages $ do+ dirStructure <- hseDirStructure+ tmpGhcDir <- liftIO $ createTemporaryDirectory (hsEnv dirStructure) "ghc"+ debug $ "Unpacking GHC tarball to " ++ tmpGhcDir+ _ <- indentMessages $ outsideProcess' "tar" ["xf", tarballPath, "-C", tmpGhcDir, "--strip-components", "1"]+ let configureScript = tmpGhcDir </> "configure"+ debug $ "Configuring GHC with prefix " ++ ghcDir dirStructure+ cwd <- liftIO getCurrentDirectory+ liftIO $ setCurrentDirectory tmpGhcDir+ make <- asks makeCmd+ let configureAndInstall = do+ _ <- indentMessages $ outsideProcess' configureScript ["--prefix=" ++ ghcDir dirStructure]+ debug $ "Installing GHC with " ++ make ++ " install"+ _ <- indentMessages $ outsideProcess' make ["install"]+ return ()+ configureAndInstall `finally` liftIO (setCurrentDirectory cwd)+ liftIO $ removeDirectoryRecursive tmpGhcDir+ return ()
+ src/Args.hs view
@@ -0,0 +1,103 @@+{-# LANGUAGE Arrows, CPP #-}++module Args (getArgs) where++import Control.Arrow+import Util.Args+import System.Directory (getCurrentDirectory)+import System.FilePath (splitPath)+import Types++#ifdef cabal+import Util.Cabal (prettyVersion)+import Paths_hsenv (version)++versionString :: String+versionString = prettyVersion version+#else+versionString :: String+versionString = "dev"+#endif++verbosityOpt, veryVerbosityOpt, skipSanityOpt, sharingOpt :: Switch++verbosityOpt = Switch { switchName = "verbose"+ , switchHelp = "Print some debugging info"+ , switchShort = Just 'v'+ }++veryVerbosityOpt = Switch { switchName = "very-verbose"+ , switchHelp = "Print some more debugging info"+ , switchShort = Nothing+ }++skipSanityOpt = Switch { switchName = "skip-sanity-check"+ , switchHelp = "Skip all the sanity checks (use at your own risk)"+ , switchShort = Nothing+ }++sharingOpt = Switch { switchName = "dont-share-cabal-cache"+ , switchHelp = "Don't share ~/.cabal/packages (hackage download cache)"+ , switchShort = Nothing+ }++nameOpt, ghcOpt :: DynOpt++nameOpt = DynOpt+ { dynOptName = "name"+ , dynOptTemplate = "NAME"+ , dynOptDescription = "current directory name"+ , dynOptHelp = "Use NAME as name of the Virtual Haskell Environment"+ }++ghcOpt = DynOpt+ { dynOptName = "ghc"+ , dynOptTemplate = "FILE"+ , dynOptDescription = "system's copy of GHC"+ , dynOptHelp =+ "Use GHC from provided tarball (e.g. ghc-7.0.4-i386-unknown-linux.tar.bz2)"+ }++makeOpt :: StaticOpt+makeOpt = StaticOpt+ { staticOptName = "make-cmd"+ , staticOptTemplate = "CMD"+ , staticOptDefault = "make"+ , staticOptHelp =+ "Used as make substitute for installing GHC from tarball (e.g. gmake)"+ }++argParser :: ArgArrow () Options+argParser = proc () -> do+ verbosityFlag <- getOpt verbosityOpt -< ()+ verbosityFlag2 <- getOpt veryVerbosityOpt -< ()+ let verboseness = case (verbosityFlag, verbosityFlag2) of+ (_, True) -> VeryVerbose+ (True, False) -> Verbose+ (False, False) -> Quiet+ nameFlag <- getOpt nameOpt -< ()+ name <- case nameFlag of+ Just name' -> returnA -< name'+ Nothing -> do+ cwd <- liftIO' getCurrentDirectory -< ()+ returnA -< last $ splitPath cwd+ ghcFlag <- getOpt ghcOpt -< ()+ let ghc = case ghcFlag of+ Nothing -> System+ Just path -> Tarball path+ skipSanityCheckFlag <- getOpt skipSanityOpt -< ()+ noSharingFlag <- getOpt sharingOpt -< ()+ make <- getOpt makeOpt -< ()+ returnA -< Options{ verbosity = verboseness+ , skipSanityCheck = skipSanityCheckFlag+ , hsEnvName = name+ , ghcSource = ghc+ , makeCmd = make+ , noSharing = noSharingFlag+ }+ where liftIO' = liftIO . const++getArgs :: IO Options+getArgs = parseArgs argParser versionString outro+ where outro = "Creates Virtual Haskell Environment in the current directory.\n"+ ++ "All files will be stored in the .hsenv_ENVNAME/ subdirectory."
+ src/MyMonad.hs view
@@ -0,0 +1,88 @@+{-# LANGUAGE GeneralizedNewtypeDeriving, ScopedTypeVariables #-}+module MyMonad ( MyMonad+ , runMyMonad+ , indentMessages+ , debug+ , info+ , trace+ , warning+ , finally+ , throwError+ , catchError+ , asks+ , gets+ , tell+ , modify+ , liftIO+ ) where++import Types++import Control.Exception as Exception (IOException, catch)+import Control.Monad.Trans (MonadIO, liftIO)+import Control.Monad.Reader (ReaderT, MonadReader, runReaderT, asks)+import Control.Monad.Writer (WriterT, MonadWriter, runWriterT, tell)+import Control.Monad.State (StateT, MonadState, evalStateT, modify, gets)+import Control.Monad.Error (ErrorT, MonadError, runErrorT, throwError, catchError)+import Control.Monad (when)+import System.IO (stderr, hPutStrLn)++import Prelude hiding (log)++newtype MyMonad a = MyMonad (StateT MyState (ReaderT Options (ErrorT MyException (WriterT [String] IO))) a)+ deriving (Functor, Monad, MonadReader Options, MonadState MyState, MonadError MyException, MonadWriter [String])++instance MonadIO MyMonad where+ liftIO m = MyMonad $ do+ x <- liftIO $ (Right `fmap` m) `Exception.catch` \(e :: IOException) -> return $ Left e+ case x of+ Left e -> throwError $ MyException $ "IO error: " ++ show e+ Right y -> return y++runMyMonad :: MyMonad a -> Options -> IO (Either MyException a, [String])+runMyMonad (MyMonad m) = runWriterT . runErrorT . runReaderT (evalStateT m (MyState 0))++finally :: MyMonad a -> MyMonad b -> MyMonad a+finally m sequel = do+ result <- (Right `fmap` m) `catchError` (return . Left)+ _ <- sequel+ case result of+ Left e -> throwError e+ Right x -> return x++indentMessages :: MyMonad a -> MyMonad a+indentMessages m = do+ modify (\s -> s{logDepth = logDepth s + 2})+ result <- m+ modify (\s -> s{logDepth = logDepth s - 2})+ return result++-- add message to private log and return adjusted message (with log depth)+-- that can be printed somewhere else+privateLog :: String -> MyMonad String+privateLog str = do+ depth <- gets logDepth+ let text = replicate (fromInteger depth) ' ' ++ str+ tell [text]+ return text++log :: Verbosity -> String -> MyMonad ()+log minLevel str = do+ text <- privateLog str+ flag <- asks verbosity+ when (flag >= minLevel) $+ liftIO $ putStrLn text++debug :: String -> MyMonad ()+debug = log Verbose++info :: String -> MyMonad ()+info = log Quiet++trace :: String -> MyMonad ()+trace = log VeryVerbose++warning :: String -> MyMonad ()+warning str = do+ text <- privateLog str+ liftIO $ hPutStrLn stderr text
+ src/PackageManagement.hs view
@@ -0,0 +1,110 @@+module PackageManagement ( Transplantable(..)+ , parseVersion+ , parsePkgInfo+ , outsideGhcPkg+ ) where++import Distribution.Package (PackageIdentifier(..), PackageName(..))+import Distribution.Version (Version(..))+import Control.Monad (unless)++import Types+import MyMonad+import Process (outsideProcess', insideProcess)+import Util.Cabal (prettyPkgInfo, prettyVersion)+import qualified Util.Cabal (parseVersion, parsePkgInfo)++outsideGhcPkg :: [String] -> MyMonad String+outsideGhcPkg = outsideProcess' "ghc-pkg"++insideGhcPkg :: [String] -> Maybe String -> MyMonad String+insideGhcPkg = insideProcess "ghc-pkg"++parseVersion :: String -> MyMonad Version+parseVersion s = case Util.Cabal.parseVersion s of+ Nothing -> throwError $ MyException $ "Couldn't parse " ++ s ++ " as a package version"+ Just version -> return version++parsePkgInfo :: String -> MyMonad PackageIdentifier+parsePkgInfo s = case Util.Cabal.parsePkgInfo s of+ Nothing -> throwError $ MyException $ "Couldn't parse package identifier " ++ s+ Just pkgInfo -> return pkgInfo++getDeps :: PackageIdentifier -> MyMonad [PackageIdentifier]+getDeps pkgInfo = do+ let prettyPkg = prettyPkgInfo pkgInfo+ debug $ "Extracting dependencies of " ++ prettyPkg+ out <- indentMessages $ outsideGhcPkg ["field", prettyPkg, "depends"]+ -- example output:+ -- depends: ghc-prim-0.2.0.0-3fbcc20c802efcd7c82089ec77d92990+ -- integer-gmp-0.2.0.0-fa82a0df93dc30b4a7c5654dd7c68cf4 builtin_rts+ case words out of+ [] -> throwError $ MyException $ "Couldn't parse ghc-pkg output to find dependencies of " ++ prettyPkg+ _:depStrings -> do -- skip 'depends:'+ indentMessages $ trace $ "Found dependency strings: " ++ unwords depStrings+ mapM parsePkgInfo depStrings++-- things that can be copied from system's GHC pkg database+-- to GHC pkg database inside virtual environment+class Transplantable a where+ transplantPackage :: a -> MyMonad ()++-- choose the highest installed version of package with this name+instance Transplantable PackageName where+ transplantPackage (PackageName packageName) = do+ debug $ "Copying package " ++ packageName ++ " to Virtual Haskell Environment."+ indentMessages $ do+ debug "Choosing package with highest version number."+ out <- indentMessages $ outsideGhcPkg ["field", packageName, "version"]+ -- example output:+ -- version: 1.1.4+ -- version: 1.2.0.3+ let extractVersionString :: String -> MyMonad String+ extractVersionString line = case words line of+ [_, x] -> return x+ _ -> throwError $ MyException $ "Couldn't extract version string from: " ++ line+ versionStrings <- mapM extractVersionString $ lines out+ indentMessages $ trace $ "Found version strings: " ++ unwords versionStrings+ versions <- mapM parseVersion versionStrings+ case versions of+ [] -> throwError $ MyException $ "No versions of package " ++ packageName ++ " found"+ (v:vs) -> do+ indentMessages $ debug $ "Found: " ++ unwords (map prettyVersion versions)+ let highestVersion = foldr max v vs+ indentMessages $ debug $ "Using version: " ++ prettyVersion highestVersion+ let pkgInfo = PackageIdentifier (PackageName packageName) highestVersion+ transplantPackage pkgInfo++-- check if this package is already installed in Virtual Haskell Environment+checkIfInstalled :: PackageIdentifier -> MyMonad Bool+checkIfInstalled pkgInfo = do+ let package = prettyPkgInfo pkgInfo+ debug $ "Checking if " ++ package ++ " is already installed."+ (do+ _ <- indentMessages $ insideGhcPkg ["describe", package] Nothing+ indentMessages $ debug "It is."+ return True) `catchError` handler+ where handler _ = do+ debug "It's not."+ return False++instance Transplantable PackageIdentifier where+ transplantPackage pkgInfo = do+ let prettyPkg = prettyPkgInfo pkgInfo+ debug $ "Copying package " ++ prettyPkg ++ " to Virtual Haskell Environment."+ indentMessages $ do+ flag <- checkIfInstalled pkgInfo+ unless flag $ do+ deps <- getDeps pkgInfo+ debug $ "Found: " ++ unwords (map prettyPkgInfo deps)+ mapM_ transplantPackage deps+ movePackage pkgInfo++-- copy single package that already has all deps satisfied+movePackage :: PackageIdentifier -> MyMonad ()+movePackage pkgInfo = do+ let prettyPkg = prettyPkgInfo pkgInfo+ debug $ "Moving package " ++ prettyPkg ++ " to Virtual Haskell Environment."+ out <- outsideGhcPkg ["describe", prettyPkg]+ _ <- insideGhcPkg ["register", "-"] (Just out)+ return ()
+ src/Paths.hs view
@@ -0,0 +1,59 @@+module Paths ( hseDirStructure+ , cabalConfigLocation+ , dotDirName+ , insidePathVar+ ) where++import Data.List (intercalate)+import System.FilePath ((</>))+import System.Directory (getCurrentDirectory)++import Util.IO (getEnvVar)+import Types+import MyMonad++-- returns record containing paths to all important directories+-- inside virtual environment dir structure+hseDirStructure :: MyMonad DirStructure+hseDirStructure = do+ cwd <- liftIO getCurrentDirectory+ dirName <- dotDirName+ let hsEnvLocation = cwd+ hsEnvDirLocation = hsEnvLocation </> dirName+ cabalDirLocation = hsEnvDirLocation </> "cabal"+ ghcDirLocation = hsEnvDirLocation </> "ghc"+ return DirStructure { hsEnv = hsEnvLocation+ , hsEnvDir = hsEnvDirLocation+ , ghcPackagePath = hsEnvDirLocation </> "ghc_pkg_db"+ , cabalDir = cabalDirLocation+ , cabalBinDir = cabalDirLocation </> "bin"+ , hsEnvBinDir = hsEnvDirLocation </> "bin"+ , ghcDir = ghcDirLocation+ , ghcBinDir = ghcDirLocation </> "bin"+ }++-- directory name of hsEnvDir+dotDirName :: MyMonad String+dotDirName = do+ name <- asks hsEnvName+ return $ ".hsenv_" ++ name++-- returns location of cabal's config file inside virtual environment dir structure+cabalConfigLocation :: MyMonad FilePath+cabalConfigLocation = do+ dirStructure <- hseDirStructure+ return $ cabalDir dirStructure </> "config"++-- returns value of $PATH env variable to be used inside virtual environment+insidePathVar :: MyMonad String+insidePathVar = do+ oldPathVar <- liftIO $ getEnvVar "PATH"+ let oldPathVarSuffix = case oldPathVar of+ Nothing -> ""+ Just x -> ':' : x+ dirStructure <- hseDirStructure+ ghc <- asks ghcSource+ let extraPathElems = case ghc of+ System -> [cabalBinDir dirStructure]+ Tarball _ -> [cabalBinDir dirStructure, ghcBinDir dirStructure]+ return $ intercalate ":" extraPathElems ++ oldPathVarSuffix
+ src/Process.hs view
@@ -0,0 +1,143 @@+module Process ( outsideProcess+ , outsideProcess'+ , insideProcess+ , ghcPkgDbPathLocation+ ) where++import MyMonad+import Paths+import Types++import Util.IO (Environment, readProcessWithExitCodeInEnv, which)++import Data.Maybe (fromMaybe)+import System.Environment (getEnvironment)+import System.Exit (ExitCode(..))+import System.FilePath ((</>))+import System.Process (readProcessWithExitCode)++runProcess :: Maybe Environment -> FilePath -> [String] -> Maybe String -> MyMonad String+runProcess env prog args input = do+ case input of+ Nothing -> return ()+ Just inp -> do+ trace "Using the following input:"+ indentMessages $ mapM_ trace $ lines inp++ let execProcess = case env of+ Nothing -> readProcessWithExitCode prog args (fromMaybe "" input)+ Just env' -> readProcessWithExitCodeInEnv env' prog args input++ (exitCode, output, errors) <- liftIO execProcess++ debug $ case exitCode of+ ExitSuccess -> "Process exited successfully"+ ExitFailure errCode -> "Process failed with exit code " ++ show errCode++ case output of+ "" -> trace "Empty process output"+ _ -> do+ trace "Process output:"+ indentMessages $ mapM_ trace $ lines output++ case errors of+ "" -> trace "Empty process error output"+ _ -> do+ trace "Process error output:"+ indentMessages $ mapM_ trace $ lines errors++ case exitCode of+ ExitSuccess -> return output+ ExitFailure errCode -> throwError $ MyException $ prog ++ " process failed with status " ++ show errCode++-- run regular process, takes:+-- * program name, looks for it in $PATH,+-- * list of arguments+-- * maybe standard input+-- returns standard output+outsideProcess :: String -> [String] -> Maybe String -> MyMonad String+outsideProcess progName args input = do+ debug $ unwords $ ["Running outside process:", progName] ++ args+ indentMessages $ do+ trace $ unwords ["Looking for", progName, "in $PATH"]+ program <- liftIO $ which Nothing progName+ case program of+ Nothing -> throwError $ MyException $ unwords ["No", progName, "in $PATH"]+ Just programPath -> do+ trace $ unwords [progName, "->", programPath]+ runProcess Nothing programPath args input++outsideProcess' :: String -> [String] -> MyMonad String+outsideProcess' progName args = outsideProcess progName args Nothing++-- returns path to GHC (installed from tarball) builtin package database+externalGhcPkgDb :: MyMonad FilePath+externalGhcPkgDb = do+ trace "Checking where GHC (installed from tarball) keeps its package database"+ indentMessages $ do+ dirStructure <- hseDirStructure+ let ghcPkg = ghcDir dirStructure </> "bin" </> "ghc-pkg"+ trace $ unwords ["Running process:", ghcPkg, "list"]+ ghcPkgOutput <- indentMessages $ runProcess Nothing ghcPkg ["list"] Nothing+ debug "Trying to parse ghc-pkg's output"+ case lines ghcPkgOutput of+ [] -> throwError $ MyException "ghc-pkg returned empty output"+ lineWithPath:_ ->+ case lineWithPath of+ "" -> throwError $ MyException "ghc-pkg's first line of output is empty"+ _ -> do+ -- ghc-pkg ends pkg db path with trailing colon+ -- but only when not run from the terminal+ let path = init lineWithPath+ debug $ "Found: " ++ path+ return path++-- returns value of GHC_PACKAGE_PATH that should be used inside virtual environment+-- defined in this module, because insideProcess needs it+ghcPkgDbPathLocation :: MyMonad String+ghcPkgDbPathLocation = do+ trace "Determining value of GHC_PACKAGE_PATH to be used inside virtual environment"+ dirStructure <- hseDirStructure+ ghc <- asks ghcSource+ case ghc of+ System -> return $ ghcPackagePath dirStructure+ Tarball _ -> do+ externalGhcPkgDbPath <- indentMessages externalGhcPkgDb+ return $ ghcPackagePath dirStructure ++ ":" ++ externalGhcPkgDbPath++virtualEnvironment :: MyMonad Environment+virtualEnvironment = do+ debug "Calculating unix env dictionary used inside virtual environment"+ indentMessages $ do+ env <- liftIO getEnvironment+ ghcPkgDb <- ghcPkgDbPathLocation+ debug $ "$GHC_PACKAGE_PATH=" ++ ghcPkgDb+ pathVar <- insidePathVar+ debug $ "$PATH=" ++ pathVar+ let varToBeOverridden var = var `elem` ["GHC_PACKAGE_PATH", "PATH"]+ strippedEnv = filter (not . varToBeOverridden . fst) env+ return $ [("GHC_PACKAGE_PATH", ghcPkgDb), ("PATH", pathVar)] ++ strippedEnv++-- run process from inside the virtual environment, takes:+-- * program name, looks for it in (in order):+-- - cabal bin dir (e.g. .hsenv*/cabal/bin)+-- - ghc bin dir (e.g. .hsenv*/ghc/bin), only when using ghc from tarball+-- - $PATH+-- * list of arguments+-- * maybe standard input+-- returns standard output+-- process is run in altered environment (new $GHC_PACKAGE_PATH env var,+-- adjusted $PATH var)+insideProcess :: String -> [String] -> Maybe String -> MyMonad String+insideProcess progName args input = do+ debug $ unwords $ ["Running inside process:", progName] ++ args+ indentMessages $ do+ pathVar <- insidePathVar+ trace $ unwords ["Looking for", progName, "in", pathVar]+ program <- liftIO $ which (Just pathVar) progName+ case program of+ Nothing -> throwError $ MyException $ unwords ["No", progName, "in", pathVar]+ Just programPath -> do+ trace $ unwords [progName, "->", programPath]+ env <- virtualEnvironment+ runProcess (Just env) programPath args input
+ src/SanityCheck.hs view
@@ -0,0 +1,64 @@+module SanityCheck (sanityCheck) where++import Control.Monad (when)+import System.Directory (doesDirectoryExist)++import Util.IO (getEnvVar, which)+import Types+import MyMonad+import Paths (hseDirStructure, dotDirName)++-- check if any virtual env is already active+checkHSE :: MyMonad ()+checkHSE = do+ hsEnvVar <- liftIO $ getEnvVar "HSENV"+ case hsEnvVar of+ Nothing -> return ()+ Just path -> do+ hsEnvNameVar <- liftIO $ getEnvVar "HSENV_NAME"+ case hsEnvNameVar of+ Nothing -> do+ debug $ "warning: HSENV environment variable is defined" ++ ", but no HSENV_NAME environment variable defined."+ throwError $ MyException $ "There is already active Virtual Haskell Environment (at " ++ path ++ ")."+ Just name ->+ throwError $ MyException $ "There is already active " ++ name ++ " Virtual Haskell Environment (at " ++ path ++ ")."++checkHsenvAlreadyExists :: MyMonad ()+checkHsenvAlreadyExists = do+ dirStructure <- hseDirStructure+ flag <- liftIO $ doesDirectoryExist $ hsEnvDir dirStructure+ dotDir <- dotDirName+ when flag $ throwError $ MyException $ "There is already " ++ dotDir ++ " directory at " ++ hsEnv dirStructure++-- check if cabal binary exist on PATH+checkCabalInstall :: MyMonad ()+checkCabalInstall = do+ cabalInstallPath <- liftIO $ which Nothing "cabal"+ case cabalInstallPath of+ Just _ -> return ()+ Nothing -> throwError $ MyException "Couldn't find cabal binary (from cabal-install package) in your $PATH."++-- check if GHC tools (ghc, ghc-pkg) exist on PATH+-- skip the check if using GHC from a tarball+checkGhc :: MyMonad ()+checkGhc = do+ ghcSrc <- asks ghcSource+ case ghcSrc of+ Tarball _ -> return ()+ System -> do+ ghcPath <- liftIO $ which Nothing "ghc"+ case ghcPath of+ Just _ -> return ()+ Nothing -> throwError $ MyException "Couldn't find ghc binary in your $PATH."+ ghc_pkgPath <- liftIO $ which Nothing "ghc-pkg"+ case ghc_pkgPath of+ Just _ -> return ()+ Nothing -> throwError $ MyException "Couldn't find ghc-pkg binary in your $PATH."++-- check if everything is sane+sanityCheck :: MyMonad ()+sanityCheck = do+ checkHSE+ checkHsenvAlreadyExists+ checkCabalInstall+ checkGhc
+ src/Skeletons.hs view
@@ -0,0 +1,39 @@+{-# LANGUAGE TemplateHaskell #-}++module Skeletons where++import Data.FileEmbed (embedFile)+import Data.ByteString.Char8 (unpack)+import System.FilePath ((</>))++activateSkel :: String+activateSkel = unpack $(embedFile $ "skeletons" </> "activate")++cabalWrapperSkel :: String+cabalWrapperSkel = unpack $(embedFile $ "skeletons" </> "cabal")++cabalConfigSkel :: String+cabalConfigSkel = unpack $(embedFile $ "skeletons" </> "cabal_config")++simpleWrappers :: [(String, String)]+simpleWrappers = [ ghcWrapperSkel+ , ghciWrapperSkel+ , ghcPkgWrapperSkel+ , ghcModWrapperSkel+ , runghcWrapperSkel+ ]++ghcWrapperSkel :: (String, String)+ghcWrapperSkel = ("ghc", unpack $(embedFile $ "skeletons" </> "ghc"))++ghciWrapperSkel :: (String, String)+ghciWrapperSkel = ("ghci", unpack $(embedFile $ "skeletons" </> "ghci"))++ghcPkgWrapperSkel :: (String, String)+ghcPkgWrapperSkel = ("ghc-pkg", unpack $(embedFile $ "skeletons" </> "ghc-pkg"))++ghcModWrapperSkel :: (String, String)+ghcModWrapperSkel = ("ghc-mod", unpack $(embedFile $ "skeletons" </> "ghc-mod"))++runghcWrapperSkel :: (String, String)+runghcWrapperSkel = ("runghc", unpack $(embedFile $ "skeletons" </> "runghc"))
+ src/Types.hs view
@@ -0,0 +1,44 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+module Types ( GhcSource(..)+ , Options(..)+ , MyState(..)+ , DirStructure(..)+ , MyException(..)+ , Verbosity(..)+ ) where++import Control.Monad.Error (Error)++data GhcSource = System -- Use System's copy of GHC+ | Tarball FilePath -- Use GHC from tarball++data Verbosity = Quiet+ | Verbose+ | VeryVerbose+ deriving (Eq, Ord)++data Options = Options { verbosity :: Verbosity+ , skipSanityCheck :: Bool+ , hsEnvName :: String -- Virtual Haskell Environment name+ , ghcSource :: GhcSource+ , makeCmd :: String -- make substitute used for 'make install' of external GHC+ , noSharing :: Bool -- don't share ~/.cabal/packages+ }++data MyState = MyState { logDepth :: Integer -- used for indentation of logging messages+ }++newtype MyException = MyException { getExceptionMessage :: String }+ deriving Error++-- Only absolute paths!+data DirStructure = DirStructure { hsEnv :: FilePath -- dir containing .hsenv_ENVNAME dir+ -- (usually dir with cabal project)+ , hsEnvDir :: FilePath -- .hsenv_ENVNAME dir+ , ghcPackagePath :: FilePath -- file (<ghc-6.12) or dir (>=ghc-6.12) containing private GHC pkg db+ , cabalDir :: FilePath -- directory with private cabal dir+ , cabalBinDir :: FilePath -- cabal's bin/ dir (used in $PATH)+ , hsEnvBinDir :: FilePath -- dir with haskell tools wrappers and activate script+ , ghcDir :: FilePath -- directory with private copy of external GHC (only used when using GHC from tarball)+ , ghcBinDir :: FilePath -- ghc's bin/ dir (with ghc[i|-pkg]) (only used when using GHC from tarball)+ }
+ src/Util/Args.hs view
@@ -0,0 +1,12 @@+module Util.Args ( parseArgs+ , GetOpt(..)+ , Switch(..)+ , DynOpt(..)+ , StaticOpt(..)+ , ArgArrow+ , liftIO+ ) where++import Util.Args.Args (parseArgs)+import Util.Args.GetOpt+import Util.Args.ArgArrow
+ src/Util/Args/ArgArrow.hs view
@@ -0,0 +1,39 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+module Util.Args.ArgArrow ( ArgArrow+ , runArgArrow+ , liftIO+ , addKnownArg+ , askArgs+ , getKnownArgs+ ) where++import Util.StaticArrowT (StaticArrowT(..), addStatic, getStatic)+import Util.Args.RawArgs (Args)+import Util.Args.ArgDescr (KnownArgs)+import Data.Monoid (mempty)+import Control.Monad.Reader (ReaderT(..), ask)+import qualified Control.Monad.Reader as Reader (liftIO)+import Control.Arrow (Kleisli(..), Arrow, ArrowChoice)+import Control.Category (Category)++-- cli options parsing arrow, that exports statically all known args, and their info+newtype ArgArrow a b = ArgArrow (StaticArrowT KnownArgs (Kleisli (ReaderT Args IO)) a b)+ deriving (Category, Arrow, ArrowChoice)++runArgArrow :: ArgArrow () a -> Args -> IO a+runArgArrow (ArgArrow (StaticArrowT _ m)) = runReaderT $ runKleisli m ()++liftIO :: (a -> IO b) -> ArgArrow a b+liftIO m = ArgArrow $ StaticArrowT mempty $ Kleisli (Reader.liftIO . m)++-- record statically new known argument+addKnownArg :: KnownArgs -> ArgArrow () ()+addKnownArg = ArgArrow . addStatic++-- returns raw parsed args+askArgs :: ArgArrow () Args+askArgs = ArgArrow $ StaticArrowT mempty $ Kleisli $ const ask++-- returns statically known (by this computation) cli args+getKnownArgs :: ArgArrow a b -> KnownArgs+getKnownArgs (ArgArrow arrow) = getStatic arrow
+ src/Util/Args/ArgDescr.hs view
@@ -0,0 +1,27 @@+module Util.Args.ArgDescr ( DefaultValue(..)+ , ArgDescr(..)+ , KnownArgs+ ) where++-- default value for cli option+data DefaultValue = ConstValue String -- explicit default value+ | DynValue String -- human readable description of a process+ -- that will provide default value++-- cli option description+data ArgDescr =+ -- switch+ SwitchDescr { argName :: String -- switch name (e.g. 'verbose' for --verbose)+ , helpMsg :: String -- human readable description of this switch+ , shortOpt :: Maybe Char -- optional short version for this switch+ -- (e.g. 'v' for '-v'+ -- as a shortcut for '--verbose')+ }+ -- option with a value+ | ValArg { argName :: String -- option name (e.g. 'key' for '--key=value')+ , valTemplate :: String -- help template for value (e.g. 'PATH' for --binary=PATH)+ , defaultValue :: DefaultValue -- default value+ , helpMsg :: String -- human readable description of this switch+ }++type KnownArgs = [ArgDescr]
+ src/Util/Args/Args.hs view
@@ -0,0 +1,86 @@+{-# LANGUAGE Arrows #-}+module Util.Args.Args (parseArgs) where++import Util.Args.ArgDescr (ArgDescr(..), KnownArgs)+import Util.Args.ArgArrow (ArgArrow, runArgArrow, askArgs, getKnownArgs, addKnownArg)+import Util.Args.RawArgs (Args(..), parseArguments)+import Control.Arrow ((>>>), returnA, arr)+import System.Environment (getArgs)+import System.IO (stderr, hPutStrLn)+import System.Exit (exitFailure, exitSuccess)+import Data.Maybe (catMaybes)+import Util.Args.Usage (usage)++-- cli arg parsing result+data ArgParseResult a = Usage+ | Help+ | Error String+ | Version+ | OK a++-- wraps a cli arg parsing computation to add few standard+-- arguments: --help (and -h) and --version+-- and allows to distinguish them in the result+helperArgArrow :: ArgArrow a b -> ArgArrow a (ArgParseResult b)+helperArgArrow arrow = proc x -> do+ addKnownArg knargs -< ()+ args <- askArgs -< ()+ if "help" `elem` switches args || 'h' `elem` shortSwitches args then+ returnA -< Help+ else if "usage" `elem` switches args then+ returnA -< Usage+ else if "version" `elem` switches args then+ returnA -< Version+ else+ arrow >>> arr OK -< x+ where knargs = [versionOpt, helpOpt]+ helpOpt = SwitchDescr "help" "Show this help message" (Just 'h')+ versionOpt = SwitchDescr "version" "Show version string" Nothing++-- prints a msg to stderr and exits program with return value 1+failWith :: String -> IO a+failWith s = hPutStrLn stderr s >> exitFailure++-- validates provided cli arguments against known argument descriptions+-- handles unknown arguments, and currently forbids positional arguments+validateArguments :: Args -> KnownArgs -> IO ()+validateArguments args knArgs+ | not $ null $ positionals args = failWith "Positional arguments are not allowed"+ | otherwise =+ either failWith return $ do+ mapM_ (validate "short switch" "-" knShortSwitches (:"")) $ shortSwitches args+ mapM_ (validate "switch" "--" knSwitches id) $ switches args+ mapM_ (validate "option" "--" knKeys id . fst) $ valArgs args+ where knShortSwitches = catMaybes $ flip map knArgs $ \x -> case x of+ SwitchDescr _ _ c -> c+ _ -> Nothing+ knSwitches = catMaybes $ flip map knArgs $ \x -> case x of+ SwitchDescr name _ _ -> Just name+ _ -> Nothing+ knKeys = catMaybes $ flip map knArgs $ \x -> case x of+ ValArg name _ _ _ -> Just name+ _ -> Nothing+ validate xName prefix knownXs showX x =+ if x `elem` knownXs then+ Right ()+ else+ Left $ "Unknown " ++ xName ++ " '" ++ prefix ++ showX x ++ "'"++-- takes a cli arg parsing computation, version string and usage msg footer+-- runs the computation on program cli arguments+-- and returns the result. if arguments validation fails,+-- prints usage message and exits with failure+parseArgs :: ArgArrow () a -> String -> String -> IO a+parseArgs arrgArr version outro = do+ args <- getArgs+ case parseArguments args of+ Left s -> failWith s+ Right parsedArgs -> do+ validateArguments parsedArgs $ getKnownArgs arrgArr'+ result <- runArgArrow arrgArr' parsedArgs+ case result of+ OK a -> return a+ Error s -> failWith s+ Version -> putStrLn version >> exitSuccess+ _ -> usage arrgArr' outro >>= putStr >> exitSuccess+ where arrgArr' = helperArgArrow arrgArr
+ src/Util/Args/GetOpt.hs view
@@ -0,0 +1,91 @@+{-# LANGUAGE MultiParamTypeClasses+ , FunctionalDependencies+ , TypeSynonymInstances+ , FlexibleInstances+ , Arrows+ #-}+module Util.Args.GetOpt ( GetOpt(..)+ , Switch(..)+ , DynOpt(..)+ , StaticOpt(..)+ ) where++import Util.Args.ArgArrow (ArgArrow, askArgs, addKnownArg)+import Util.Args.ArgDescr (DefaultValue(..), ArgDescr(..))+import Util.Args.RawArgs (Args(..))+import Data.Maybe (fromMaybe)+import Control.Arrow (returnA)++-- getOpt method takes a cli option description and returns at runtime value for that option.+-- it also statically records information about such option (and uses it to generate usage)+class GetOpt a b | a -> b where+ getOpt :: a -> ArgArrow () b++-- description of a cli switch, getOpt-ing it will return True if it's present+-- in cli args and False otherwise+data Switch =+ Switch { switchName :: String -- switch long name (e.g. 'verbose' for '--verbose')+ , switchHelp :: String -- human readable switch description (used for usage msg)+ , switchShort :: Maybe Char -- optional short version of this switch+ -- (e.g. 'v' for '-v')+ }++instance GetOpt Switch Bool where+ getOpt descr = proc () -> do+ addKnownArg [SwitchDescr (switchName descr)+ (switchHelp descr)+ (switchShort descr)] -< ()+ args <- askArgs -< ()+ let longSwitchStatus = switchName descr `elem` switches args+ switchStatus = case switchShort descr of+ Nothing -> longSwitchStatus+ Just c -> longSwitchStatus || c `elem` shortSwitches args+ returnA -< switchStatus++-- description of a key,value cli argument, that if not present,+-- defaults to a value returned by some dynamic process+-- getOpt-ing it will return Just its value if it's present in cli args,+-- otherwise Nothing+data DynOpt =+ DynOpt { dynOptName :: String -- key name (e.g. 'foo' for '--foo=bar')+ , dynOptTemplate :: String -- help template for value+ -- (e.g. 'PATH' for --binary=PATH)+ , dynOptDescription :: String -- human readable description of a process+ -- that will provide default value+ -- (e.g. 'current directory')+ , dynOptHelp :: String -- human readable switch description+ -- (used for usage msg)+ }++instance GetOpt DynOpt (Maybe String) where+ getOpt descr = proc () -> do+ addKnownArg [ValArg (dynOptName descr)+ (dynOptTemplate descr)+ (DynValue $ dynOptDescription descr)+ (dynOptHelp descr)] -< ()+ args <- askArgs -< ()+ returnA -< lookup (dynOptName descr) $ valArgs args++-- description of a key,value cli argument, that if not present,+-- defaults to an explicit value+-- getOpt-ing it will return String with its value if it's present in cli args,+-- otherwise default value is returned+data StaticOpt =+ StaticOpt { staticOptName :: String -- key name (e.g. 'foo' for '--foo=bar')+ , staticOptTemplate :: String -- help template for value+ -- (e.g. 'PATH' for --binary=PATH)+ , staticOptDefault :: String -- default value for this argument+ , staticOptHelp :: String -- human readable switch description+ -- (used for usage msg)+ }++instance GetOpt StaticOpt String where+ getOpt descr = proc () -> do+ addKnownArg [ValArg (staticOptName descr)+ (staticOptTemplate descr)+ (DynValue $ staticOptDefault descr)+ (staticOptHelp descr)] -< ()+ args <- askArgs -< ()+ returnA -< fromMaybe (staticOptDefault descr)+ $ lookup (staticOptName descr)+ $ valArgs args
+ src/Util/Args/RawArgs.hs view
@@ -0,0 +1,40 @@+module Util.Args.RawArgs ( Args(..)+ , parseArguments+ ) where++import Data.Monoid (Monoid(..))+import Control.Monad (liftM)+import Control.Monad.Instances ()+import Util.List (breakOn)++{-# ANN Args "HLint: ignore Use String" #-}+-- parsed command line options+data Args = Args { shortSwitches :: [Char] -- list of enabled short switches+ , switches :: [String] -- list of enabled switches+ , valArgs :: [(String, String)] -- list of (key,value) cli opts+ , positionals :: [String] -- positional arguments+ }++instance Monoid Args where+ mempty = Args [] [] [] []+ Args xs1 ys1 zs1 us1 `mappend` Args xs2 ys2 zs2 us2 =+ Args (xs1 ++ xs2) (ys1 ++ ys2) (zs1 ++ zs2) (us1 ++ us2)++-- parses a single word or returns an error+parseArgument :: String -> Either String Args+parseArgument ('-':'-':arg) =+ Right $ case breakOn '=' arg of+ Nothing -> mempty{switches = [arg]}+ Just (key, val) -> mempty{valArgs = [(key, val)]}+parseArgument ['-', c] = Right mempty{shortSwitches = [c]}+parseArgument param@('-':_) = Left $ "Invalid option: '" ++ param ++ "'"+parseArgument arg = Right mempty{positionals = [arg]}++-- parses many words or returns an error+parseArguments :: [String] -> Either String Args+parseArguments args =+ case breakOn "--" args of+ Nothing -> mconcat `liftM` mapM parseArgument args+ Just (args', rest) -> do+ parsedArgs <- mapM parseArgument args'+ return $ mconcat parsedArgs `mappend` mempty{positionals = rest}
+ src/Util/Args/Usage.hs view
@@ -0,0 +1,46 @@+module Util.Args.Usage (usage) where++import Util.Args.ArgDescr (ArgDescr(..), DefaultValue(..))+import Data.Function (on)+import Util.WordWrap (wordWrap)+import Data.List(sortBy)+import Util.Args.ArgArrow (ArgArrow, getKnownArgs)+import Util.String (padTo)+import System.Environment (getProgName)++-- pretty prints cli arg description for usage+-- left column contains cli arg header (e.g. '--verbose', or '--binary=PATH')+-- right column contains info messages for that argument+-- returns list of lines+showFlagDescr :: ArgDescr -> [String]+showFlagDescr argDescr = zipWith makeLine lefts helpLines+ where lefts = argLine : repeat ""+ argLine = case argDescr of+ SwitchDescr name _ Nothing -> "--" ++ name+ SwitchDescr name _ (Just c) ->+ concat ["-", [c], " ", "--", name]+ ValArg name tmpl _ _ -> concat ["--", name, "=", tmpl]+ msgLines = wordWrap 60 $ case argDescr of+ SwitchDescr _ hlp _ -> hlp+ ValArg _ _ default' help ->+ concat [help, "\n", defaultsLine default']+ helpLines = if length argLine < 18 then+ msgLines+ else+ "" : msgLines -- line with argument is too long+ -- make more room for it+ defaultsLine (ConstValue s) = concat ["(defaults to '", s, "')"]+ defaultsLine (DynValue s) = concat ["(defaults to ", s, ")"]+ makeLine infoLine descrLine = (infoLine `padTo` 20) ++ descrLine++-- returns string with formatted cli arg usage help message+-- argument descriptions are extracted from arg parsing computation+-- adds simple header and appends provided footer+usage :: ArgArrow a b -> String -> IO String+usage arrow outro = do+ self <- getProgName+ let intro = "usage: " ++ self ++ " [FLAGS]"+ return $ unlines $ [intro, "", "Flags:"] ++ flagsDescr ++ [""] ++ outro'+ where flagsDescr = concatMap showFlagDescr $ argDescrSort $ getKnownArgs arrow+ argDescrSort = sortBy (compare `on` argName)+ outro' = wordWrap 80 outro
+ src/Util/Cabal.hs view
@@ -0,0 +1,39 @@+module Util.Cabal ( prettyVersion+ , prettyPkgInfo+ , parseVersion+ , parsePkgInfo+ ) where++import Distribution.Version (Version(..))+import Distribution.Package (PackageIdentifier(..), PackageName(..))+import Distribution.Compat.ReadP (readP_to_S)+import Distribution.Text (parse, Text)++import Data.Char (isSpace)+import Data.List (isPrefixOf, intercalate)++-- render Version to human and ghc-pkg readable string+prettyVersion :: Version -> String+prettyVersion (Version [] _) = ""+prettyVersion (Version numbers _) = intercalate "." $ map show numbers++-- render PackageIdentifier to human and ghc-pkg readable string+prettyPkgInfo :: PackageIdentifier -> String+prettyPkgInfo (PackageIdentifier (PackageName name) (Version [] _)) = name+prettyPkgInfo (PackageIdentifier (PackageName name) version) =+ name ++ "-" ++ prettyVersion version++parseVersion :: String -> Maybe Version+parseVersion = parseCheck++parseCheck :: Text a => String -> Maybe a+parseCheck str =+ case [ x | (x,ys) <- readP_to_S parse str, all isSpace ys ] of+ [x] -> Just x+ _ -> Nothing++parsePkgInfo :: String -> Maybe PackageIdentifier+parsePkgInfo str | "builtin_" `isPrefixOf` str =+ let name = drop (length "builtin_") str -- ghc-pkg doesn't like builtin_ prefix+ in Just $ PackageIdentifier (PackageName name) $ Version [] []+ | otherwise = parseCheck str
+ src/Util/IO.hs view
@@ -0,0 +1,83 @@+module Util.IO ( getEnvVar+ , makeExecutable+ , readProcessWithExitCodeInEnv+ , Environment+ , createTemporaryDirectory+ , which+ ) where++import System.Environment (getEnv)+import System.IO.Error (isDoesNotExistError)+import System.Directory (getPermissions, setPermissions, executable, removeFile, createDirectory, doesFileExist)+import Control.Concurrent (forkIO, putMVar, takeMVar, newEmptyMVar)+import Control.Exception as Exception (catch, evaluate)+import System.Process (runInteractiveProcess, waitForProcess)+import System.IO (hGetContents, hPutStr, hFlush, hClose, openTempFile)+import System.Exit (ExitCode)+import Data.List.Split (splitOn)+import Control.Monad (foldM)+import System.FilePath ((</>))++-- Computation getEnvVar var returns Just the value of the environment variable var,+-- or Nothing if the environment variable does not exist+getEnvVar :: String -> IO (Maybe String)+getEnvVar var = Just `fmap` getEnv var `Exception.catch` noValueHandler+ where noValueHandler e | isDoesNotExistError e = return Nothing+ | otherwise = ioError e++makeExecutable :: FilePath -> IO ()+makeExecutable path = do+ perms <- getPermissions path+ setPermissions path perms{executable = True}++type Environment = [(String, String)]++-- like readProcessWithExitCode, but takes additional environment argument+readProcessWithExitCodeInEnv :: Environment -> FilePath -> [String] -> Maybe String -> IO (ExitCode, String, String)+readProcessWithExitCodeInEnv env progName args input = do+ (inh, outh, errh, pid) <- runInteractiveProcess progName args Nothing (Just env)+ out <- hGetContents outh+ outMVar <- newEmptyMVar+ _ <- forkIO $ evaluate (length out) >> putMVar outMVar ()+ err <- hGetContents errh+ errMVar <- newEmptyMVar+ _ <- forkIO $ evaluate (length err) >> putMVar errMVar ()+ case input of+ Just inp | not (null inp) -> hPutStr inh inp >> hFlush inh+ _ -> return ()+ hClose inh+ takeMVar outMVar+ hClose outh+ takeMVar errMVar+ hClose errh+ ex <- waitForProcess pid+ return (ex, out, err)++-- similar to openTempFile, but creates a temporary directory+-- and returns its path+createTemporaryDirectory :: FilePath -> String -> IO FilePath+createTemporaryDirectory parentDir templateName = do+ (path, handle) <- openTempFile parentDir templateName+ hClose handle+ removeFile path+ createDirectory path+ return path++which :: Maybe String -> String -> IO (Maybe FilePath)+which pathVar name = do+ path <- case pathVar of+ Nothing -> getEnvVar "PATH"+ Just path -> return $ Just path+ case path of+ Nothing -> return Nothing+ Just path' -> do+ let pathElems = splitOn ":" path'+ aux x@(Just _) _ = return x+ aux Nothing pathDir = do+ let programPath = pathDir </> name+ flag <- doesFileExist programPath+ if flag then+ return $ Just programPath+ else+ return Nothing+ foldM aux Nothing pathElems
+ src/Util/List.hs view
@@ -0,0 +1,7 @@+module Util.List (breakOn) where++breakOn :: Eq a => a -> [a] -> Maybe ([a], [a])+breakOn sep = aux []+ where aux _ [] = Nothing+ aux prevs (x:xs) | x == sep = Just (reverse prevs, xs)+ | otherwise = aux (x:prevs) xs
+ src/Util/StaticArrowT.hs view
@@ -0,0 +1,33 @@+module Util.StaticArrowT ( StaticArrowT(..)+ , addStatic+ , getStatic+ ) where++import Data.Monoid (Monoid(..))+import Control.Arrow (Arrow(..), ArrowChoice(..))+import qualified Control.Category as C++-- arrow transformer, that adds static information+-- to underlying computation+data StaticArrowT m arr a b = StaticArrowT m (arr a b)++instance (C.Category arr, Monoid m) => C.Category (StaticArrowT m arr) where+ id = StaticArrowT mempty C.id+ StaticArrowT m2 arr2 . StaticArrowT m1 arr1 =+ StaticArrowT (m2 `mappend` m1) $ arr2 C.. arr1++instance (Arrow arr, Monoid m) => Arrow (StaticArrowT m arr) where+ arr f = StaticArrowT mempty $ arr f+ first (StaticArrowT m arrow) = StaticArrowT m $ first arrow++instance (ArrowChoice arr, Monoid m) => ArrowChoice (StaticArrowT m arr) where+ left (StaticArrowT m arrow) = StaticArrowT m $ left arrow++-- simplest computation with specified static information+addStatic :: (Monoid m, Arrow arr) => m -> StaticArrowT m arr a a+addStatic m = StaticArrowT m C.id++-- returns static information from the whole computation+-- (without running it)+getStatic :: (Monoid m, Arrow arr) => StaticArrowT m arr a b -> m+getStatic (StaticArrowT m _) = m
+ src/Util/String.hs view
@@ -0,0 +1,5 @@+module Util.String (padTo) where++padTo :: String -> Int -> String+padTo s n | length s < n = take n $ s ++ repeat ' '+ | otherwise = s
+ src/Util/Template.hs view
@@ -0,0 +1,22 @@+module Util.Template ( substs+ ) where++import Data.List (isPrefixOf)++-- Simple templating system+-- most of the existing tools are either too complicated+-- or use $ (or even ${}) chars for variables, which is unfortunate+-- for use with [ba]sh templates.++type Substitution = (String, String)++-- substitute all occurences of FROM to TO+subst :: Substitution -> String -> String+subst _ [] = []+subst phi@(from, to) input@(x:xs)+ | from `isPrefixOf` input = to ++ subst phi (drop (length from) input)+ | otherwise = x:subst phi xs++-- multi version of subst+substs :: [Substitution] -> String -> String+substs phis str = foldr subst str phis
+ src/Util/WordWrap.hs view
@@ -0,0 +1,27 @@+module Util.WordWrap (wordWrap) where++import Data.Char (isSpace)++trim :: String -> String+trim = trimAndReverse . trimAndReverse+ where trimAndReverse = reverse . dropWhile isSpace++reverseBreak :: (a -> Bool) -> [a] -> ([a], [a])+reverseBreak f xs = (reverse before, reverse after)+ where (after, before) = break f $ reverse xs++wordWrap :: Int -> String -> [String]+wordWrap maxLen line =+ case break (== '\n') chunk of+ (beginning, '\n':rest) -> beginning : wordWrap maxLen (rest ++ chunks)+ _ -> wordWrap' maxLen line+ where (chunk, chunks) = splitAt maxLen line++wordWrap' :: Int -> String -> [String]+wordWrap' maxLen line+ | length line <= maxLen = [trim line]+ | any isSpace beforeMax = trim beforeSpace : wordWrap maxLen (afterSpace ++ afterMax)+ | otherwise = firstBigWord : wordWrap maxLen rest+ where (beforeMax, afterMax) = splitAt maxLen line+ (beforeSpace, afterSpace) = reverseBreak isSpace beforeMax+ (firstBigWord, rest) = break isSpace line
+ src/hsenv.hs view
@@ -0,0 +1,48 @@+import System.IO (stderr, hPutStrLn)+import System.Exit (exitFailure)+import System.FilePath ((</>))++import Types+import MyMonad+import Actions+import SanityCheck (sanityCheck)+import Args (getArgs)+import Paths (dotDirName)++main :: IO ()+main = do+ options <- getArgs+ (result, messageLog) <- runMyMonad realMain options+ case result of+ Left err -> do+ hPutStrLn stderr $ getExceptionMessage err+ hPutStrLn stderr ""+ hPutStrLn stderr "hsenv.log file contains detailed description of the process."+ let errorLog = unlines $ messageLog ++ ["", getExceptionMessage err]+ writeFile "hsenv.log" errorLog+ exitFailure+ Right () -> do+ let dotDir = ".hsenv_" ++ hsEnvName options+ writeFile (dotDir </> "hsenv.log") $ unlines messageLog++realMain :: MyMonad ()+realMain = do+ skipSanityCheckFlag <- asks skipSanityCheck+ if skipSanityCheckFlag then+ info "WARNING: sanity checks are disabled."+ else+ sanityCheck+ createDirStructure+ installGhc+ initGhcDb+ copyBaseSystem+ installCabalConfig+ installActivateScript+ installCabalWrapper+ installSimpleWrappers+ installProgSymlinks+ symlinkToSkeleton "runghc" "runhaskell"+ cabalUpdate+ info ""+ dotDir <- dotDirName+ info $ "To activate the new environment use 'source " ++ dotDir ++ "/bin/activate'"