Cabal-1.22.5.0/0000755000000000000000000000000012627136221011131 5ustar0000000000000000Cabal-1.22.5.0/Cabal.cabal0000644000000000000000000002752612627136221013133 0ustar0000000000000000name: Cabal version: 1.22.5.0 copyright: 2003-2006, Isaac Jones 2005-2011, Duncan Coutts license: BSD3 license-file: LICENSE author: Isaac Jones Duncan Coutts maintainer: cabal-devel@haskell.org homepage: http://www.haskell.org/cabal/ bug-reports: https://github.com/haskell/cabal/issues synopsis: A framework for packaging Haskell software description: The Haskell Common Architecture for Building Applications and Libraries: a framework defining a common interface for authors to more easily build their Haskell applications in a portable way. . The Haskell Cabal is part of a larger infrastructure for distributing, organizing, and cataloging Haskell libraries and tools. category: Distribution cabal-version: >=1.10 build-type: Custom -- Even though we do use the default Setup.lhs it's vital to bootstrapping -- that we build Setup.lhs using our own local Cabal source code. extra-source-files: README.md tests/README.md changelog doc/developing-packages.markdown doc/index.markdown doc/installing-packages.markdown doc/misc.markdown -- Generated with 'misc/gen-extra-source-files.sh' & 'M-x sort-lines': tests/PackageTests/BenchmarkExeV10/Foo.hs tests/PackageTests/BenchmarkExeV10/benchmarks/bench-Foo.hs tests/PackageTests/BenchmarkExeV10/my.cabal tests/PackageTests/BenchmarkOptions/BenchmarkOptions.cabal tests/PackageTests/BenchmarkOptions/test-BenchmarkOptions.hs tests/PackageTests/BenchmarkStanza/my.cabal tests/PackageTests/BuildDeps/GlobalBuildDepsNotAdditive1/GlobalBuildDepsNotAdditive1.cabal tests/PackageTests/BuildDeps/GlobalBuildDepsNotAdditive1/MyLibrary.hs tests/PackageTests/BuildDeps/GlobalBuildDepsNotAdditive2/GlobalBuildDepsNotAdditive2.cabal tests/PackageTests/BuildDeps/GlobalBuildDepsNotAdditive2/lemon.hs tests/PackageTests/BuildDeps/InternalLibrary0/MyLibrary.hs tests/PackageTests/BuildDeps/InternalLibrary0/my.cabal tests/PackageTests/BuildDeps/InternalLibrary0/programs/lemon.hs tests/PackageTests/BuildDeps/InternalLibrary1/MyLibrary.hs tests/PackageTests/BuildDeps/InternalLibrary1/my.cabal tests/PackageTests/BuildDeps/InternalLibrary1/programs/lemon.hs tests/PackageTests/BuildDeps/InternalLibrary2/MyLibrary.hs tests/PackageTests/BuildDeps/InternalLibrary2/my.cabal tests/PackageTests/BuildDeps/InternalLibrary2/programs/lemon.hs tests/PackageTests/BuildDeps/InternalLibrary2/to-install/MyLibrary.hs tests/PackageTests/BuildDeps/InternalLibrary2/to-install/my.cabal tests/PackageTests/BuildDeps/InternalLibrary3/MyLibrary.hs tests/PackageTests/BuildDeps/InternalLibrary3/my.cabal tests/PackageTests/BuildDeps/InternalLibrary3/programs/lemon.hs tests/PackageTests/BuildDeps/InternalLibrary3/to-install/MyLibrary.hs tests/PackageTests/BuildDeps/InternalLibrary3/to-install/my.cabal tests/PackageTests/BuildDeps/InternalLibrary4/MyLibrary.hs tests/PackageTests/BuildDeps/InternalLibrary4/my.cabal tests/PackageTests/BuildDeps/InternalLibrary4/programs/lemon.hs tests/PackageTests/BuildDeps/InternalLibrary4/to-install/MyLibrary.hs tests/PackageTests/BuildDeps/InternalLibrary4/to-install/my.cabal tests/PackageTests/BuildDeps/SameDepsAllRound/MyLibrary.hs tests/PackageTests/BuildDeps/SameDepsAllRound/SameDepsAllRound.cabal tests/PackageTests/BuildDeps/SameDepsAllRound/lemon.hs tests/PackageTests/BuildDeps/SameDepsAllRound/pineapple.hs tests/PackageTests/BuildDeps/TargetSpecificDeps1/MyLibrary.hs tests/PackageTests/BuildDeps/TargetSpecificDeps1/lemon.hs tests/PackageTests/BuildDeps/TargetSpecificDeps1/my.cabal tests/PackageTests/BuildDeps/TargetSpecificDeps2/MyLibrary.hs tests/PackageTests/BuildDeps/TargetSpecificDeps2/lemon.hs tests/PackageTests/BuildDeps/TargetSpecificDeps2/my.cabal tests/PackageTests/BuildDeps/TargetSpecificDeps3/MyLibrary.hs tests/PackageTests/BuildDeps/TargetSpecificDeps3/lemon.hs tests/PackageTests/BuildDeps/TargetSpecificDeps3/my.cabal tests/PackageTests/BuildTestSuiteDetailedV09/Dummy.hs tests/PackageTests/BuildTestSuiteDetailedV09/my.cabal tests/PackageTests/CMain/Bar.hs tests/PackageTests/CMain/Setup.hs tests/PackageTests/CMain/foo.c tests/PackageTests/CMain/my.cabal tests/PackageTests/DeterministicAr/Lib.hs tests/PackageTests/DeterministicAr/my.cabal tests/PackageTests/EmptyLib/empty/empty.cabal tests/PackageTests/Haddock/CPP.hs tests/PackageTests/Haddock/Literate.lhs tests/PackageTests/Haddock/NoCPP.hs tests/PackageTests/Haddock/Simple.hs tests/PackageTests/Haddock/my.cabal tests/PackageTests/OrderFlags/Foo.hs tests/PackageTests/OrderFlags/my.cabal tests/PackageTests/PathsModule/Executable/Main.hs tests/PackageTests/PathsModule/Executable/my.cabal tests/PackageTests/PathsModule/Library/my.cabal tests/PackageTests/PreProcess/Foo.hsc tests/PackageTests/PreProcess/Main.hs tests/PackageTests/PreProcess/my.cabal tests/PackageTests/ReexportedModules/ReexportedModules.cabal tests/PackageTests/TemplateHaskell/dynamic/Exe.hs tests/PackageTests/TemplateHaskell/dynamic/Lib.hs tests/PackageTests/TemplateHaskell/dynamic/TH.hs tests/PackageTests/TemplateHaskell/dynamic/my.cabal tests/PackageTests/TemplateHaskell/profiling/Exe.hs tests/PackageTests/TemplateHaskell/profiling/Lib.hs tests/PackageTests/TemplateHaskell/profiling/TH.hs tests/PackageTests/TemplateHaskell/profiling/my.cabal tests/PackageTests/TemplateHaskell/vanilla/Exe.hs tests/PackageTests/TemplateHaskell/vanilla/Lib.hs tests/PackageTests/TemplateHaskell/vanilla/TH.hs tests/PackageTests/TemplateHaskell/vanilla/my.cabal tests/PackageTests/TestOptions/TestOptions.cabal tests/PackageTests/TestOptions/test-TestOptions.hs tests/PackageTests/TestStanza/my.cabal tests/PackageTests/TestSuiteExeV10/Foo.hs tests/PackageTests/TestSuiteExeV10/my.cabal tests/PackageTests/TestSuiteExeV10/tests/test-Foo.hs tests/Setup.hs tests/hackage/check.sh tests/hackage/download.sh tests/hackage/unpack.sh tests/misc/ghc-supported-languages.hs source-repository head type: git location: https://github.com/haskell/cabal/ subdir: Cabal flag bundled-binary-generic default: False library build-depends: base >= 4.4 && < 5, deepseq >= 1.3 && < 1.5, filepath >= 1 && < 1.5, directory >= 1 && < 1.3, process >= 1.1.0.1 && < 1.3, time >= 1.1 && < 1.6, containers >= 0.1 && < 0.6, array >= 0.1 && < 0.6, pretty >= 1 && < 1.2, bytestring >= 0.9 if flag(bundled-binary-generic) build-depends: binary >= 0.5 && < 0.7 else build-depends: binary >= 0.7 && < 0.8 -- Needed for GHC.Generics before GHC 7.6 if impl(ghc < 7.6) build-depends: ghc-prim >= 0.2 && < 0.3 if !os(windows) build-depends: unix >= 2.0 && < 2.8 ghc-options: -Wall -fno-ignore-asserts -fwarn-tabs exposed-modules: Distribution.Compat.CreatePipe Distribution.Compat.Environment Distribution.Compat.Exception Distribution.Compat.ReadP Distribution.Compiler Distribution.InstalledPackageInfo Distribution.License Distribution.Make Distribution.ModuleName Distribution.Package Distribution.PackageDescription Distribution.PackageDescription.Check Distribution.PackageDescription.Configuration Distribution.PackageDescription.Parse Distribution.PackageDescription.PrettyPrint Distribution.PackageDescription.Utils Distribution.ParseUtils Distribution.ReadE Distribution.Simple Distribution.Simple.Bench Distribution.Simple.Build Distribution.Simple.Build.Macros Distribution.Simple.Build.PathsModule Distribution.Simple.BuildPaths Distribution.Simple.BuildTarget Distribution.Simple.CCompiler Distribution.Simple.Command Distribution.Simple.Compiler Distribution.Simple.Configure Distribution.Simple.GHC Distribution.Simple.GHCJS Distribution.Simple.Haddock Distribution.Simple.HaskellSuite Distribution.Simple.Hpc Distribution.Simple.Install Distribution.Simple.InstallDirs Distribution.Simple.JHC Distribution.Simple.LHC Distribution.Simple.LocalBuildInfo Distribution.Simple.PackageIndex Distribution.Simple.PreProcess Distribution.Simple.PreProcess.Unlit Distribution.Simple.Program Distribution.Simple.Program.Ar Distribution.Simple.Program.Builtin Distribution.Simple.Program.Db Distribution.Simple.Program.Find Distribution.Simple.Program.GHC Distribution.Simple.Program.HcPkg Distribution.Simple.Program.Hpc Distribution.Simple.Program.Ld Distribution.Simple.Program.Run Distribution.Simple.Program.Script Distribution.Simple.Program.Strip Distribution.Simple.Program.Types Distribution.Simple.Register Distribution.Simple.Setup Distribution.Simple.SrcDist Distribution.Simple.Test Distribution.Simple.Test.ExeV10 Distribution.Simple.Test.LibV09 Distribution.Simple.Test.Log Distribution.Simple.UHC Distribution.Simple.UserHooks Distribution.Simple.Utils Distribution.System Distribution.TestSuite Distribution.Text Distribution.Utils.NubList Distribution.Verbosity Distribution.Version Language.Haskell.Extension other-modules: Distribution.Compat.Binary Distribution.Compat.CopyFile Distribution.Compat.TempFile Distribution.GetOpt Distribution.Simple.GHC.Internal Distribution.Simple.GHC.IPI641 Distribution.Simple.GHC.IPI642 Distribution.Simple.GHC.ImplInfo Paths_Cabal if flag(bundled-binary-generic) other-modules: Distribution.Compat.Binary.Class Distribution.Compat.Binary.Generic default-language: Haskell98 default-extensions: CPP -- Small, fast running tests. test-suite unit-tests type: exitcode-stdio-1.0 hs-source-dirs: tests other-modules: UnitTests.Distribution.Compat.CreatePipe UnitTests.Distribution.Compat.ReadP UnitTests.Distribution.Utils.NubList main-is: UnitTests.hs build-depends: base, test-framework, test-framework-hunit, test-framework-quickcheck2, HUnit, QuickCheck < 2.8, Cabal ghc-options: -Wall default-language: Haskell98 -- Large, system tests that build packages. test-suite package-tests type: exitcode-stdio-1.0 main-is: PackageTests.hs other-modules: PackageTests.BenchmarkExeV10.Check PackageTests.BenchmarkOptions.Check PackageTests.BenchmarkStanza.Check PackageTests.BuildDeps.GlobalBuildDepsNotAdditive1.Check PackageTests.BuildDeps.GlobalBuildDepsNotAdditive2.Check PackageTests.BuildDeps.InternalLibrary0.Check PackageTests.BuildDeps.InternalLibrary1.Check PackageTests.BuildDeps.InternalLibrary2.Check PackageTests.BuildDeps.InternalLibrary3.Check PackageTests.BuildDeps.InternalLibrary4.Check PackageTests.BuildDeps.SameDepsAllRound.Check PackageTests.BuildDeps.TargetSpecificDeps1.Check PackageTests.BuildDeps.TargetSpecificDeps2.Check PackageTests.BuildDeps.TargetSpecificDeps3.Check PackageTests.BuildTestSuiteDetailedV09.Check PackageTests.CMain.Check PackageTests.DeterministicAr.Check PackageTests.EmptyLib.Check PackageTests.Haddock.Check PackageTests.OrderFlags.Check PackageTests.PackageTester PackageTests.PathsModule.Executable.Check PackageTests.PathsModule.Library.Check PackageTests.PreProcess.Check PackageTests.ReexportedModules.Check PackageTests.TemplateHaskell.Check PackageTests.TestOptions.Check PackageTests.TestStanza.Check PackageTests.TestSuiteExeV10.Check hs-source-dirs: tests build-depends: base, containers, test-framework, test-framework-quickcheck2 >= 0.2.12, test-framework-hunit, HUnit, QuickCheck >= 2.1.0.1 && < 2.8, Cabal, process, directory, filepath, extensible-exceptions, bytestring, regex-posix, old-time if !os(windows) build-depends: unix ghc-options: -Wall default-extensions: CPP default-language: Haskell98 Cabal-1.22.5.0/changelog0000644000000000000000000005047412627136221013015 0ustar00000000000000001.22.5.0 * Don't recompile C sources unless needed (#2601). (Luke Iannini) * Support Haddock response files. * Add frameworks when linking a dynamic library. 1.22.4.0 Ryan Thomas June 2015 * Add libname install-dirs variable, use it by default. Fixes #2437. (Edward Z. Yang) * Reduce temporary directory name length, fixes #2502. (Edward Z. Yang) * Workaround for #2527. (Mikhail Glushenkov) 1.22.3.0 Ryan Thomas April 2015 * Fix for the ghcjs-pkg version number handling (Luite Stegeman) * filterConfigureFlags: filter more flags (Mikhail Glushenkov) * Cabal check will fail on -fprof-auto passed as a ghc-option - Fixes #2479 (John Chee) 1.22.2.0 Ryan Thomas March 2015 * Don't pass '--{en,dis}able-profiling' to old setup. * Add -Wall police * Fix dependencies on 'old-time' * Fix test interface detailed-0.9 with GHC 7.10 * Fix HPC tests with GHC 7.10 * Make sure to pass the package key to ghc * Use --package-{name|version} when available for Haddock when available * Put full package name and version in library names * Fully specify package key format, so external tools can generate it. 1.22.0.0 Johan Tibell January 2015 * Support GHC 7.10. * Experimental support for emitting DWARF debug info. * Preliminary support for relocatable packages. * Allow cabal to be used inside cabal exec enviroments. * hpc: support mutliple "ways" (e.g. profiling and vanilla). * Support GHCJS. * Improved command line documentation. * Add '-none' constraint syntax for version ranges (#2093). * Make the default doc index file path compiler/arch/os-dependent (#2136). * Warn instead of dying when generating documentation and hscolour isn't installed (455f51622fa38347db62197a04bb0fa5b928ff17). * Support the new BinaryLiterals extension (1f25ab3c5eff311ada73c6c987061b80e9bbebd9). * Warn about 'ghc-prof-options: -auto-all' in 'cabal check' (#2162). * Add preliminary support for multiple instances of the same package version installed side-by-side (#2002). * New binary build config format - faster build times (#2076). * Support module thinning and renaming (#2038). * Add a new license type: UnspecifiedLicense (#2141). * Remove support for Hugs and nhc98 (#2168). * Invoke 'tar' with '--formar ustar' if possible in 'sdist' (#1903). * Replace --enable-library-coverage with --enable-coverage, which enables program coverage for all components (#1945). * Suggest that `ExitFailure 9` is probably due to memory exhaustion (#1522). * Drop support for Haddock < 2.0 (#1808, #1718). * Make 'cabal test'/'cabal bench' build only what's needed for running tests/benchmarks (#1821). * Build shared libraries by default when linking executables dynamically. * Build profiled libraries by default when profiling executables. 1.20.0.1 Johan Tibell May 2014 * Fix streaming test output. 1.20.0.0 Johan Tibell April 2014 * Rewrite user guide * Fix repl Ctrl+C handling * Add haskell-suite compiler support * Add __HADDOCK_VERSION__ define * Allow specifying exact dependency version using hash * Rename extra-html-files to extra-doc-files * Add parallel build support for GHC 7.8 and later * Don't call ranlib on OS X * Avoid re-linking executables, test suites, and benchmarks unnecessarily, shortening build times * Add --allow-newer which allows upper version bounds to be ignored * Add --enable-library-stripping * Add command for freezing dependencies * Allow repl to be used outside Cabal packages * Add --require-sandbox * Don't use --strip-unneeded on OS X or iOS * Add new license-files field got additional licenses * Fix if(solaris) on some Solaris versions * Don't use -dylib-install-name on OS X with GHC > 7.8 * Add DragonFly as a known OS * Improve pretty-printing of Cabal files * Add test flag --show-details=streaming for real-time test output * Add exec command 1.10.2.0 Duncan Coutts June 2011 * Include test suites in cabal sdist * Fix for conditionals in test suite stanzas in .cabal files * Fix permissions of directories created during install * Fix for global builds when $HOME env var is not set 1.10.1.0 Duncan Coutts February 2011 * Improved error messages when test suites are not enabled * Template parameters allowed in test --test-option(s) flag * Improved documentation of the test feature * Relaxed QA check on cabal-version when using test-suite sections * haddock command now allows both --hoogle and --html at the same time * Find ghc-version-specific instances of the hsc2hs program * Preserve file executable permissions in sdist tarballs * Pass gcc location and flags to ./configure scripts * Get default gcc flags from ghc 1.10.0.0 Duncan Coutts November 2010 * New cabal test feature * Initial support for UHC * New default-language and other-languages fields (e.g. Haskell98/2010) * New default-extensions and other-extensions fields * Deprecated extensions field (for packages using cabal-version >=1.10) * Cabal-version field must now only be of the form ">= x.y" * Removed deprecated --copy-prefix= feature * Auto-reconfigure when .cabal file changes * Workaround for haddock overwriting .hi and .o files when using TH * Extra cpp flags used with hsc2hs and c2hs (-D${os}_BUILD_OS etc) * New cpp define VERSION_ gives string version of dependencies * User guide source now in markdown format for easier editing * Improved checks and error messages for C libraries and headers * Removed BSD4 from the list of suggested licenses * Updated list of known language extensions * Fix for include paths to allow C code to import FFI stub.h files * Fix for intra-package dependencies on OSX * Stricter checks on various bits of .cabal file syntax * Minor fixes for c2hs 1.8.0.6 Duncan Coutts June 2010 * Fix 'register --global/--user' 1.8.0.4 Duncan Coutts March 2010 * Set dylib-install-name for dynalic libs on OSX * Stricter configure check that compiler supports a package's extensions * More configure-time warnings * Hugs can compile Cabal lib again * Default datadir now follows prefix on Windows * Support for finding installed packages for hugs * Cabal version macros now have proper parenthesis * Reverted change to filter out deps of non-buildable components * Fix for registering implace when using a specific package db * Fix mismatch between $os and $arch path template variables * Fix for finding ar.exe on Windows, always pick ghc's version * Fix for intra-package dependencies with ghc-6.12 1.8.0.2 Duncan Coutts December 2009 * Support for GHC-6.12 * New unique installed package IDs which use a package hash * Allow executables to depend on the lib within the same package * Dependencies for each component apply only to that component (previously applied to all the other components too) * Added new known license MIT and versioned GPL and LGPL * More liberal package version range syntax * Package registration files are now UTF8 * Support for LHC and JHC-0.7.2 * Deprecated RecordPuns extension in favour of NamedFieldPuns * Deprecated PatternSignatures extension in favor of ScopedTypeVariables * New VersionRange semantic view as a sequence of intervals * Improved package quality checks * Minor simplification in a couple Setup.hs hooks * Beginnings of a unit level testsuite using QuickCheck * Various bug fixes * Various internal cleanups 1.6.0.2 Duncan Coutts February 2009 * New configure-time check for C headers and libraries * Added language extensions present in ghc-6.10 * Added support for NamedFieldPuns extension in ghc-6.8 * Fix in configure step for ghc-6.6 on Windows * Fix warnings in Path_pkgname.hs module on Windows * Fix for exotic flags in ld-options field * Fix for using pkg-config in a package with a lib and an executable * Fix for building haddock docs for exes that use the Paths module * Fix for installing header files in subdirectories * Fix for the case of building profiling libs but not ordinary libs * Fix read-only attribute of installed files on Windows * Ignore ghc -threaded flag when profiling in ghc-6.8 and older 1.6.0.1 Duncan Coutts October 2008 * Export a compat function to help alex and happy 1.6.0.0 Duncan Coutts October 2008 * Support for ghc-6.10 * Source control repositories can now be specified in .cabal files * Bug report URLs can be now specified in .cabal files * Wildcards now allowed in data-files and extra-source-files fields * New syntactic sugar for dependencies "build-depends: foo ==1.2.*" * New cabal_macros.h provides macros to test versions of dependencies * Relocatable bindists now possible on unix via env vars * New 'exposed' field allows packages to be not exposed by default * Install dir flags can now use $os and $arch variables * New --builddir flag allows multiple builds from a single sources dir * cc-options now only apply to .c files, not for -fvia-C * cc-options are not longer propagated to dependent packages * The cpp/cc/ld-options fields no longer use ',' as a separator * hsc2hs is now called using gcc instead of using ghc as gcc * New api for manipulating sets and graphs of packages * Internal api improvements and code cleanups * Minor improvements to the user guide * Miscellaneous minor bug fixes 1.4.0.2 Duncan Coutts August 2008 * Fix executable stripping default * Fix striping exes on OSX that export dynamic symbols (like ghc) * Correct the order of arguments given by --prog-options= * Fix corner case with overlapping user and global packages * Fix for modules that use pre-processing and .hs-boot files * Clarify some points in the user guide and readme text * Fix verbosity flags passed to sub-command like haddock * Fix sdist --snapshot * Allow meta-packages that contain no modules or C code * Make the generated Paths module -Wall clean on Windows 1.4.0.1 Duncan Coutts June 2008 * Fix a bug which caused '.' to always be in the sources search path * Haddock-2.2 and later do now support the --hoogle flag 1.4.0.0 Duncan Coutts June 2008 * Rewritten command line handling support * Command line completion with bash * Better support for Haddock 2 * Improved support for nhc98 * Removed support for ghc-6.2 * Haddock markup in .lhs files now supported * Default colour scheme for highlighted source code * Default prefix for --user installs is now $HOME/.cabal * All .cabal files are treaded as UTF-8 and must be valid * Many checks added for common mistakes * New --package-db= option for specific package databases * Many internal changes to support cabal-install * Stricter parsing for version strings, eg dissalows "1.05" * Improved user guide introduction * Programatica support removed * New options --program-prefix/suffix allows eg versioned programs * Support packages that use .hs-boot files * Fix sdist for Main modules that require preprocessing * New configure -O flag with optimisation level 0--2 * Provide access to "x-" extension fields through the Cabal api * Added check for broken installed packages * Added warning about using inconsistent versions of dependencies * Strip binary executable files by default with an option to disable * New options to add site-specific include and library search paths * Lift the restriction that libraries must have exposed-modules * Many bugs fixed. * Many internal structural improvements and code cleanups 1.2.4.0 Duncan Coutts June 2008 * Released with GHC 6.8.3 * Backported several fixes and minor improvements from Cabal-1.4 * Use a default colour scheme for sources with hscolour >=1.9 * Support --hyperlink-source for Haddock >= 2.0 * Fix for running in a non-writable directory * Add OSX -framework arguments when linking executables * Updates to the user guide * Allow build-tools names to include + and _ * Export autoconfUserHooks and simpleUserHooks * Export ccLdOptionsBuildInfo for Setup.hs scripts * Export unionBuildInfo and make BuildInfo an instance of Monoid * Fix to allow the 'main-is' module to use a pre-processor 1.2.3.0 Duncan Coutts Nov 2007 * Released with GHC 6.8.2 * Includes full list of GHC language extensions * Fix infamous "dist/conftest.c" bug * Fix configure --interfacedir= * Find ld.exe on Windows correctly * Export PreProcessor constructor and mkSimplePreProcessor * Fix minor bug in unlit code * Fix some markup in the haddock docs 1.2.2.0 Duncan Coutts Nov 2007 * Released with GHC 6.8.1 * Support haddock-2.0 * Support building DSOs with GHC * Require reconfiguring if the .cabal file has changed * Fix os(windows) configuration test * Fix building documentation * Fix building packages on Solaris * Other minor bug fixes 1.2.1 Duncan Coutts Oct 2007 * To be included in GHC 6.8.1 * New field "cpp-options" used when preprocessing Haskell modules * Fixes for hsc2hs when using ghc * C source code gets compiled with -O2 by default * OS aliases, to allow os(windows) rather than requiring os(mingw32) * Fix cleaning of 'stub' files * Fix cabal-setup, command line ui that replaces "runhaskell Setup.hs" * Build docs even when dependent packages docs are missing * Allow the --html-dir to be specified at configure time * Fix building with ghc-6.2 * Other minor bug fixes and build fixes 1.2.0 Duncan Coutts Sept 2007 * To be included in GHC 6.8.x * New configurations feature * Can make haddock docs link to hilighted sources (with hscolour) * New flag to allow linking to haddock docs on the web * Supports pkg-config * New field "build-tools" for tool dependencies * Improved c2hs support * Preprocessor output no longer clutters source dirs * Separate "includes" and "install-includes" fields * Makefile command to generate makefiles for building libs with GHC * New --docdir configure flag * Generic --with-prog --prog-args configure flags * Better default installation paths on Windows * Install paths can be specified relative to each other * License files now installed * Initial support for NHC (incomplete) * Consistent treatment of verbosity * Reduced verbosity of configure step by default * Improved helpfulness of output messages * Help output now clearer and fits in 80 columns * New setup register --gen-pkg-config flag for distros * Major internal refactoring, hooks api has changed * Dozens of bug fixes 1.1.6.2 Duncan Coutts May 2007 * Released with GHC 6.6.1 * Handle windows text file encoding for .cabal files * Fix compiling a executable for profiling that uses Template Haskell * Other minor bug fixes and user guide clarifications 1.1.6.1 Duncan Coutts Oct 2006 * fix unlit code * fix escaping in register.sh 1.1.6 Duncan Coutts Oct 2006 * Released with GHC 6.6 * Added support for hoogle * Allow profiling and normal builds of libs to be chosen indepentantly * Default installation directories on Win32 changed * Register haddock docs with ghc-pkg * Get haddock to make hyperlinks to dependent package docs * Added BangPatterns language extension * Various bug fixes 1.1.4 Duncan Coutts May 2006 * Released with GHC 6.4.2 * Better support for packages that need to install header files * cabal-setup added, but not installed by default yet * Implemented "setup register --inplace" * Have packages exposed by default with ghc-6.2 * It is no longer necessary to run 'configure' before 'clean' or 'sdist' * Added support for ghc's -split-objs * Initial support for JHC * Ignore extension fields in .cabal files (fields begining with "x-") * Some changes to command hooks API to improve consistency * Hugs support improvements * Added GeneralisedNewtypeDeriving language extension * Added cabal-version field * Support hidden modules with haddock * Internal code refactoring * More bug fixes 1.1.3 Isaac Jones Sept 2005 * WARNING: Interfaces not documented in the user's guide may change in future releases. * Move building of GHCi .o libs to the build phase rather than register phase. (from Duncan Coutts) * Use .tar.gz for source package extension * Uses GHC instead of cpphs if the latter is not available * Added experimental "command hooks" which completely override the default behavior of a command. * Some bugfixes 1.1.1 Isaac Jones July 2005 * WARNING: Interfaces not documented in the user's guide may change in future releases. * Handles recursive modules for GHC 6.2 and GHC 6.4. * Added "setup test" command (Used with UserHook) * implemented handling of _stub.{c,h,o} files * Added support for profiling * Changed install prefix of libraries (pref/pkgname-version to prefix/pkgname-version/compname-version) * Added pattern guards as a language extension * Moved some functionality to Language.Haskell.Extension * Register / unregister .bat files for windows * Exposed more of the API * Added support for the hide-all-packages flag in GHC > 6.4 * Several bug fixes 1.0 Isaac Jones March 11 2005 * Released with GHC 6.4, Hugs March 2005, and nhc98 1.18 * Some sanity checking 0.5 Isaac Jones Wed Feb 19 2005 * WARNING: this is a pre-release and the interfaces are still likely to change until we reach a 1.0 release. * Hooks interfaces changed * Added preprocessors to user hooks * No more executable-modules or hidden-modules. Use "other-modules" instead. * Certain fields moved into BuildInfo, much refactoring * extra-libs -> extra-libraries * Added --gen-script to configure and unconfigure. * modules-ghc (etc) now ghc-modules (etc) * added new fields including "synopsis" * Lots of bug fixes * spaces can sometimes be used instead of commas * A user manual has appeared (Thanks, ross!) * for ghc 6.4, configures versionsed depends properly * more features to ./setup haddock 0.4 Isaac Jones Sun Jan 16 2005 * Much thanks to all the awesome fptools hackers who have been working hard to build the Haskell Cabal! * Interface Changes: ** WARNING: this is a pre-release and the interfaces are still likely to change until we reach a 1.0 release. ** Instead of Package.description, you should name your description files .cabal. In particular, we suggest that you name it .cabal, but this is not enforced (yet). Multiple .cabal files in the same directory is an error, at least for now. ** ./setup install --install-prefix is gone. Use ./setup copy --copy-prefix instead. ** The "Modules" field is gone. Use "hidden-modules", "exposed-modules", and "executable-modules". ** Build-depends is now a package-only field, and can't go into executable stanzas. Build-depends is a package-to-package relationship. ** Some new fields. Use the Source. * New Features ** Cabal is now included as a package in the CVS version of fptools. That means it'll be released as "-package Cabal" in future versions of the compilers, and if you are a bleeding-edge user, you can grab it from the CVS repository with the compilers. ** Hugs compatibility and NHC98 compatibility should both be improved. ** Hooks Interface / Autoconf compatibility: Most of the hooks interface is hidden for now, because it's not finalized. I have exposed only "defaultMainWithHooks" and "defaultUserHooks". This allows you to use a ./configure script to preprocess "foo.buildinfo", which gets merged with "foo.cabal". In future releases, we'll expose UserHooks, but we're definitely going to change the interface to those. The interface to the two functions I've exposed should stay the same, though. ** ./setup haddock is a baby feature which pre-processes the source code with hscpp and runs haddock on it. This is brand new and hardly tested, so you get to knock it around and see what you think. ** Some commands now actually implement verbosity. ** The preprocessors have been tested a bit more, and seem to work OK. Please give feedback if you use these. 0.3 Isaac Jones Sun Jan 16 2005 * Unstable snapshot release * From now on, stable releases are even. 0.2 Isaac Jones * Adds more HUGS support and preprocessor support. Cabal-1.22.5.0/LICENSE0000644000000000000000000000341112627136221012135 0ustar0000000000000000Copyright (c) 2003-2014, Isaac Jones, Simon Marlow, Martin Sjögren, Bjorn Bringert, Krasimir Angelov, Malcolm Wallace, Ross Patterson, Ian Lynagh, Duncan Coutts, Thomas Schilling, Johan Tibell, Mikhail Glushenkov 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 Isaac Jones 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. Cabal-1.22.5.0/README.md0000644000000000000000000001227112627136221012413 0ustar0000000000000000The Cabal library package ========================= See the [Cabal web site] for more information. If you also want the `cabal` command-line program, you need the [cabal-install] package in addition to this library. [cabal-install]: ../cabal-install/README.md Installing the Cabal library ============================ If you already have the `cabal` program --------------------------------------- In this case run: $ cabal install However, if you do not have an existing version of the `cabal` program, you first must install the Cabal library. To avoid this bootstrapping problem, you can install the Cabal library directly as described below. Installing as a user (no root or administrator access) ------------------------------------------------------ ghc -threaded --make Setup ./Setup configure --user ./Setup build ./Setup install Note the use of the `--user` flag at the configure step. Compiling 'Setup' rather than using `runghc Setup` is much faster and works on Windows. For all packages other than Cabal itself, it is fine to use `runghc`. This will install into `$HOME/.cabal/` on Unix and into `Documents and Settings\$User\Application Data\cabal\` on Windows. If you want to install elsewhere, use the `--prefix=` flag at the configure step. Installing as root or Administrator ----------------------------------- ghc -threaded --make Setup ./Setup configure ./Setup build sudo ./Setup install Compiling Setup rather than using `runghc Setup` is much faster and works on Windows. For all packages other than Cabal itself, it is fine to use `runghc`. This will install into `/usr/local` on Unix, and on Windows it will install into `$ProgramFiles/Haskell`. If you want to install elsewhere, use the `--prefix=` flag at the configure step. Using older versions of GHC and Cabal ====================================== It is recommended that you leave any pre-existing version of Cabal installed. In particular, it is *essential* you keep the version that came with GHC itself, since other installed packages require it (for instance, the "ghc" API package). Prior to GHC 6.4.2, however, GHC did not deal particularly well with having multiple versions of packages installed at once. So if you are using GHC 6.4.1 or older and you have an older version of Cabal installed, you should probably remove it by running: $ ghc-pkg unregister Cabal or, if you had Cabal installed only for your user account, run: $ ghc-pkg unregister Cabal --user The `filepath` dependency ========================= Cabal uses the [filepath] package, so it must be installed first. GHC version 6.6.1 and later come with `filepath`, however, earlier versions do not by default. If you do not already have `filepath`, you need to install it. You can use any existing version of Cabal to do that. If you have neither Cabal nor `filepath`, it is slightly harder but still possible. Unpack Cabal and `filepath` into separate directories. For example: tar -xzf filepath-1.1.0.0.tar.gz tar -xzf Cabal-1.6.0.0.tar.gz # rename to make the following instructions simpler: mv filepath-1.1.0.0/ filepath/ mv Cabal-1.6.0.0/ Cabal/ cd Cabal ghc -i../filepath -cpp --make Setup.hs -o ../filepath/setup cd ../filepath/ ./setup configure --user ./setup build ./setup install This installs `filepath` so that you can install Cabal with the normal method. [filepath]: http://hackage.haskell.org/package/filepath More information ================ Please see the [Cabal web site] for the [user guide] and [API documentation]. There is additional information available on the [development wiki]. [user guide]: http://www.haskell.org/cabal/users-guide [API documentation]: http://www.haskell.org/cabal/release/cabal-latest/doc/API/Cabal/Distribution-Simple.html [development wiki]: https://github.com/haskell/cabal/wiki Bugs ==== Please report bugs and feature requests to Cabal's [bug tracker]. Your help --------- To help Cabal's development, it is enormously helpful to know from Cabal's users what their most pressing problems are with Cabal and [Hackage]. You may have a favourite Cabal bug or limitation. Look at Cabal's [bug tracker]. Ensure that the problem is reported there and adequately described. Comment on the issue to report how much of a problem the bug is for you. Subscribe to the issues's notifications to discussed requirements and keep informed on progress. For feature requests, it is helpful if there is a description of how you would expect to interact with the new feature. [Hackage]: http://hackage.haskell.org Source code =========== You can get the master development branch using: $ git clone https://github.com/haskell/cabal.git Credits ======= Cabal developers (in alphabetical order): - Krasimir Angelov - Bjorn Bringert - Duncan Coutts - Isaac Jones - David Himmelstrup ("Lemmih") - Simon Marlow - Ross Patterson - Thomas Schilling - Martin Sjögren - Malcolm Wallace - and nearly 30 other people have contributed occasional patches Cabal specification authors: - Isaac Jones - Simon Marlow - Ross Patterson - Simon Peyton Jones - Malcolm Wallace [bug tracker]: https://github.com/haskell/cabal/issues [Cabal web site]: http://www.haskell.org/cabal/ Cabal-1.22.5.0/Setup.hs0000644000000000000000000000072412627136221012570 0ustar0000000000000000import Distribution.Simple main :: IO () main = defaultMain -- Although this looks like the Simple build type, it is in fact vital that -- we use this Setup.hs because it'll get compiled against the local copy -- of the Cabal lib, thus enabling Cabal to bootstrap itself without relying -- on any previous installation. This also means we can use any new features -- immediately because we never have to worry about building Cabal with an -- older version of itself. Cabal-1.22.5.0/Distribution/0000755000000000000000000000000012627136220013607 5ustar0000000000000000Cabal-1.22.5.0/Distribution/Compiler.hs0000644000000000000000000001611412627136220015720 0ustar0000000000000000{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-} ----------------------------------------------------------------------------- -- | -- Module : Distribution.Compiler -- Copyright : Isaac Jones 2003-2004 -- License : BSD3 -- -- Maintainer : cabal-devel@haskell.org -- Portability : portable -- -- This has an enumeration of the various compilers that Cabal knows about. It -- also specifies the default compiler. Sadly you'll often see code that does -- case analysis on this compiler flavour enumeration like: -- -- > case compilerFlavor comp of -- > GHC -> GHC.getInstalledPackages verbosity packageDb progconf -- > JHC -> JHC.getInstalledPackages verbosity packageDb progconf -- -- Obviously it would be better to use the proper 'Compiler' abstraction -- because that would keep all the compiler-specific code together. -- Unfortunately we cannot make this change yet without breaking the -- 'UserHooks' api, which would break all custom @Setup.hs@ files, so for the -- moment we just have to live with this deficiency. If you're interested, see -- ticket #57. module Distribution.Compiler ( -- * Compiler flavor CompilerFlavor(..), buildCompilerId, buildCompilerFlavor, defaultCompilerFlavor, parseCompilerFlavorCompat, -- * Compiler id CompilerId(..), -- * Compiler info CompilerInfo(..), unknownCompilerInfo, AbiTag(..), abiTagString ) where import Distribution.Compat.Binary (Binary) import Data.Data (Data) import Data.Typeable (Typeable) import Data.Maybe (fromMaybe) import Distribution.Version (Version(..)) import GHC.Generics (Generic) import Language.Haskell.Extension (Language, Extension) import qualified System.Info (compilerName, compilerVersion) import Distribution.Text (Text(..), display) import qualified Distribution.Compat.ReadP as Parse import qualified Text.PrettyPrint as Disp import Text.PrettyPrint ((<>)) import qualified Data.Char as Char (toLower, isDigit, isAlphaNum) import Control.Monad (when) data CompilerFlavor = GHC | GHCJS | NHC | YHC | Hugs | HBC | Helium | JHC | LHC | UHC | HaskellSuite String -- string is the id of the actual compiler | OtherCompiler String deriving (Generic, Show, Read, Eq, Ord, Typeable, Data) instance Binary CompilerFlavor knownCompilerFlavors :: [CompilerFlavor] knownCompilerFlavors = [GHC, GHCJS, NHC, YHC, Hugs, HBC, Helium, JHC, LHC, UHC] instance Text CompilerFlavor where disp (OtherCompiler name) = Disp.text name disp (HaskellSuite name) = Disp.text name disp NHC = Disp.text "nhc98" disp other = Disp.text (lowercase (show other)) parse = do comp <- Parse.munch1 Char.isAlphaNum when (all Char.isDigit comp) Parse.pfail return (classifyCompilerFlavor comp) classifyCompilerFlavor :: String -> CompilerFlavor classifyCompilerFlavor s = fromMaybe (OtherCompiler s) $ lookup (lowercase s) compilerMap where compilerMap = [ (display compiler, compiler) | compiler <- knownCompilerFlavors ] --TODO: In some future release, remove 'parseCompilerFlavorCompat' and use -- ordinary 'parse'. Also add ("nhc", NHC) to the above 'compilerMap'. -- | Like 'classifyCompilerFlavor' but compatible with the old ReadS parser. -- -- It is compatible in the sense that it accepts only the same strings, -- eg "GHC" but not "ghc". However other strings get mapped to 'OtherCompiler'. -- The point of this is that we do not allow extra valid values that would -- upset older Cabal versions that had a stricter parser however we cope with -- new values more gracefully so that we'll be able to introduce new value in -- future without breaking things so much. -- parseCompilerFlavorCompat :: Parse.ReadP r CompilerFlavor parseCompilerFlavorCompat = do comp <- Parse.munch1 Char.isAlphaNum when (all Char.isDigit comp) Parse.pfail case lookup comp compilerMap of Just compiler -> return compiler Nothing -> return (OtherCompiler comp) where compilerMap = [ (show compiler, compiler) | compiler <- knownCompilerFlavors , compiler /= YHC ] buildCompilerFlavor :: CompilerFlavor buildCompilerFlavor = classifyCompilerFlavor System.Info.compilerName buildCompilerVersion :: Version buildCompilerVersion = System.Info.compilerVersion buildCompilerId :: CompilerId buildCompilerId = CompilerId buildCompilerFlavor buildCompilerVersion -- | The default compiler flavour to pick when compiling stuff. This defaults -- to the compiler used to build the Cabal lib. -- -- However if it's not a recognised compiler then it's 'Nothing' and the user -- will have to specify which compiler they want. -- defaultCompilerFlavor :: Maybe CompilerFlavor defaultCompilerFlavor = case buildCompilerFlavor of OtherCompiler _ -> Nothing _ -> Just buildCompilerFlavor -- ------------------------------------------------------------ -- * Compiler Id -- ------------------------------------------------------------ data CompilerId = CompilerId CompilerFlavor Version deriving (Eq, Generic, Ord, Read, Show) instance Binary CompilerId instance Text CompilerId where disp (CompilerId f (Version [] _)) = disp f disp (CompilerId f v) = disp f <> Disp.char '-' <> disp v parse = do flavour <- parse version <- (Parse.char '-' >> parse) Parse.<++ return (Version [] []) return (CompilerId flavour version) lowercase :: String -> String lowercase = map Char.toLower -- ------------------------------------------------------------ -- * Compiler Info -- ------------------------------------------------------------ -- | Compiler information used for resolving configurations. Some fields can be -- set to Nothing to indicate that the information is unknown. data CompilerInfo = CompilerInfo { compilerInfoId :: CompilerId, -- ^ Compiler flavour and version. compilerInfoAbiTag :: AbiTag, -- ^ Tag for distinguishing incompatible ABI's on the same architecture/os. compilerInfoCompat :: Maybe [CompilerId], -- ^ Other implementations that this compiler claims to be compatible with, if known. compilerInfoLanguages :: Maybe [Language], -- ^ Supported language standards, if known. compilerInfoExtensions :: Maybe [Extension] -- ^ Supported extensions, if known. } deriving (Generic, Show, Read) instance Binary CompilerInfo data AbiTag = NoAbiTag | AbiTag String deriving (Generic, Show, Read) instance Binary AbiTag instance Text AbiTag where disp NoAbiTag = Disp.empty disp (AbiTag tag) = Disp.text tag parse = do tag <- Parse.munch (\c -> Char.isAlphaNum c || c == '_') if null tag then return NoAbiTag else return (AbiTag tag) abiTagString :: AbiTag -> String abiTagString NoAbiTag = "" abiTagString (AbiTag tag) = tag -- | Make a CompilerInfo of which only the known information is its CompilerId, -- its AbiTag and that it does not claim to be compatible with other -- compiler id's. unknownCompilerInfo :: CompilerId -> AbiTag -> CompilerInfo unknownCompilerInfo compilerId abiTag = CompilerInfo compilerId abiTag (Just []) Nothing Nothing Cabal-1.22.5.0/Distribution/GetOpt.hs0000644000000000000000000003320712627136220015352 0ustar0000000000000000----------------------------------------------------------------------------- -- | -- Module : Distribution.GetOpt -- Copyright : (c) Sven Panne 2002-2005 -- License : BSD-style (see the file libraries/base/LICENSE) -- -- Maintainer : libraries@haskell.org -- Portability : portable -- -- This library provides facilities for parsing the command-line options -- in a standalone program. It is essentially a Haskell port of the GNU -- @getopt@ library. -- ----------------------------------------------------------------------------- {- Sven Panne Oct. 1996 (small changes Dec. 1997) Two rather obscure features are missing: The Bash 2.0 non-option hack (if you don't already know it, you probably don't want to hear about it...) and the recognition of long options with a single dash (e.g. '-help' is recognised as '--help', as long as there is no short option 'h'). Other differences between GNU's getopt and this implementation: * To enforce a coherent description of options and arguments, there are explanation fields in the option/argument descriptor. * Error messages are now more informative, but no longer POSIX compliant... :-( And a final Haskell advertisement: The GNU C implementation uses well over 1100 lines, we need only 195 here, including a 46 line example! :-) -} {-# OPTIONS_HADDOCK hide #-} module Distribution.GetOpt ( -- * GetOpt getOpt, getOpt', usageInfo, ArgOrder(..), OptDescr(..), ArgDescr(..), -- * Example -- $example ) where import Data.List ( isPrefixOf, intercalate, find ) import Data.Maybe ( isJust ) -- |What to do with options following non-options data ArgOrder a = RequireOrder -- ^ no option processing after first non-option | Permute -- ^ freely intersperse options and non-options | ReturnInOrder (String -> a) -- ^ wrap non-options into options {-| Each 'OptDescr' describes a single option. The arguments to 'Option' are: * list of short option characters * list of long option strings (without \"--\") * argument descriptor * explanation of option for user -} data OptDescr a = -- description of a single options: Option [Char] -- list of short option characters [String] -- list of long option strings (without "--") (ArgDescr a) -- argument descriptor String -- explanation of option for user -- |Describes whether an option takes an argument or not, and if so -- how the argument is injected into a value of type @a@. data ArgDescr a = NoArg a -- ^ no argument expected | ReqArg (String -> a) String -- ^ option requires argument | OptArg (Maybe String -> a) String -- ^ optional argument data OptKind a -- kind of cmd line arg (internal use only): = Opt a -- an option | UnreqOpt String -- an un-recognized option | NonOpt String -- a non-option | EndOfOpts -- end-of-options marker (i.e. "--") | OptErr String -- something went wrong... -- | Return a string describing the usage of a command, derived from -- the header (first argument) and the options described by the -- second argument. usageInfo :: String -- header -> [OptDescr a] -- option descriptors -> String -- nicely formatted decription of options usageInfo header optDescr = unlines (header:table) where (ss,ls,ds) = unzip3 [ (intercalate ", " (map (fmtShort ad) sos) ,concatMap (fmtLong ad) (take 1 los) ,d) | Option sos los ad d <- optDescr ] ssWidth = (maximum . map length) ss lsWidth = (maximum . map length) ls dsWidth = 30 `max` (80 - (ssWidth + lsWidth + 3)) table = [ " " ++ padTo ssWidth so' ++ " " ++ padTo lsWidth lo' ++ " " ++ d' | (so,lo,d) <- zip3 ss ls ds , (so',lo',d') <- fmtOpt dsWidth so lo d ] padTo n x = take n (x ++ repeat ' ') fmtOpt :: Int -> String -> String -> String -> [(String, String, String)] fmtOpt descrWidth so lo descr = case wrapText descrWidth descr of [] -> [(so,lo,"")] (d:ds) -> (so,lo,d) : [ ("","",d') | d' <- ds ] fmtShort :: ArgDescr a -> Char -> String fmtShort (NoArg _ ) so = "-" ++ [so] fmtShort (ReqArg _ _) so = "-" ++ [so] fmtShort (OptArg _ _) so = "-" ++ [so] fmtLong :: ArgDescr a -> String -> String fmtLong (NoArg _ ) lo = "--" ++ lo fmtLong (ReqArg _ ad) lo = "--" ++ lo ++ "=" ++ ad fmtLong (OptArg _ ad) lo = "--" ++ lo ++ "[=" ++ ad ++ "]" wrapText :: Int -> String -> [String] wrapText width = map unwords . wrap 0 [] . words where wrap :: Int -> [String] -> [String] -> [[String]] wrap 0 [] (w:ws) | length w + 1 > width = wrap (length w) [w] ws wrap col line (w:ws) | col + length w + 1 > width = reverse line : wrap 0 [] (w:ws) wrap col line (w:ws) = let col' = col + length w + 1 in wrap col' (w:line) ws wrap _ [] [] = [] wrap _ line [] = [reverse line] {-| Process the command-line, and return the list of values that matched (and those that didn\'t). The arguments are: * The order requirements (see 'ArgOrder') * The option descriptions (see 'OptDescr') * The actual command line arguments (presumably got from 'System.Environment.getArgs'). 'getOpt' returns a triple consisting of the option arguments, a list of non-options, and a list of error messages. -} getOpt :: ArgOrder a -- non-option handling -> [OptDescr a] -- option descriptors -> [String] -- the command-line arguments -> ([a],[String],[String]) -- (options,non-options,error messages) getOpt ordering optDescr args = (os,xs,es ++ map errUnrec us) where (os,xs,us,es) = getOpt' ordering optDescr args {-| This is almost the same as 'getOpt', but returns a quadruple consisting of the option arguments, a list of non-options, a list of unrecognized options, and a list of error messages. -} getOpt' :: ArgOrder a -- non-option handling -> [OptDescr a] -- option descriptors -> [String] -- the command-line arguments -> ([a],[String], [String] ,[String]) -- (options,non-options,unrecognized,error messages) getOpt' _ _ [] = ([],[],[],[]) getOpt' ordering optDescr (arg:args) = procNextOpt opt ordering where procNextOpt (Opt o) _ = (o:os,xs,us,es) procNextOpt (UnreqOpt u) _ = (os,xs,u:us,es) procNextOpt (NonOpt x) RequireOrder = ([],x:rest,[],[]) procNextOpt (NonOpt x) Permute = (os,x:xs,us,es) procNextOpt (NonOpt x) (ReturnInOrder f) = (f x :os, xs,us,es) procNextOpt EndOfOpts RequireOrder = ([],rest,[],[]) procNextOpt EndOfOpts Permute = ([],rest,[],[]) procNextOpt EndOfOpts (ReturnInOrder f) = (map f rest,[],[],[]) procNextOpt (OptErr e) _ = (os,xs,us,e:es) (opt,rest) = getNext arg args optDescr (os,xs,us,es) = getOpt' ordering optDescr rest -- take a look at the next cmd line arg and decide what to do with it getNext :: String -> [String] -> [OptDescr a] -> (OptKind a,[String]) getNext ('-':'-':[]) rest _ = (EndOfOpts,rest) getNext ('-':'-':xs) rest optDescr = longOpt xs rest optDescr getNext ('-': x :xs) rest optDescr = shortOpt x xs rest optDescr getNext a rest _ = (NonOpt a,rest) -- handle long option longOpt :: String -> [String] -> [OptDescr a] -> (OptKind a,[String]) longOpt ls rs optDescr = long ads arg rs where (opt,arg) = break (=='=') ls getWith p = [ o | o@(Option _ xs _ _) <- optDescr , isJust (find (p opt) xs)] exact = getWith (==) options = if null exact then getWith isPrefixOf else exact ads = [ ad | Option _ _ ad _ <- options ] optStr = "--" ++ opt long (_:_:_) _ rest = (errAmbig options optStr,rest) long [NoArg a ] [] rest = (Opt a,rest) long [NoArg _ ] ('=':_) rest = (errNoArg optStr,rest) long [ReqArg _ d] [] [] = (errReq d optStr,[]) long [ReqArg f _] [] (r:rest) = (Opt (f r),rest) long [ReqArg f _] ('=':xs) rest = (Opt (f xs),rest) long [OptArg f _] [] rest = (Opt (f Nothing),rest) long [OptArg f _] ('=':xs) rest = (Opt (f (Just xs)),rest) long _ _ rest = (UnreqOpt ("--"++ls),rest) -- handle short option shortOpt :: Char -> String -> [String] -> [OptDescr a] -> (OptKind a,[String]) shortOpt y ys rs optDescr = short ads ys rs where options = [ o | o@(Option ss _ _ _) <- optDescr, s <- ss, y == s ] ads = [ ad | Option _ _ ad _ <- options ] optStr = '-':[y] short (_:_:_) _ rest = (errAmbig options optStr,rest) short (NoArg a :_) [] rest = (Opt a,rest) short (NoArg a :_) xs rest = (Opt a,('-':xs):rest) short (ReqArg _ d:_) [] [] = (errReq d optStr,[]) short (ReqArg f _:_) [] (r:rest) = (Opt (f r),rest) short (ReqArg f _:_) xs rest = (Opt (f xs),rest) short (OptArg f _:_) [] rest = (Opt (f Nothing),rest) short (OptArg f _:_) xs rest = (Opt (f (Just xs)),rest) short [] [] rest = (UnreqOpt optStr,rest) short [] xs rest = (UnreqOpt (optStr++xs),rest) -- miscellaneous error formatting errAmbig :: [OptDescr a] -> String -> OptKind a errAmbig ods optStr = OptErr (usageInfo header ods) where header = "option `" ++ optStr ++ "' is ambiguous; could be one of:" errReq :: String -> String -> OptKind a errReq d optStr = OptErr ("option `" ++ optStr ++ "' requires an argument " ++ d ++ "\n") errUnrec :: String -> String errUnrec optStr = "unrecognized option `" ++ optStr ++ "'\n" errNoArg :: String -> OptKind a errNoArg optStr = OptErr ("option `" ++ optStr ++ "' doesn't allow an argument\n") {- ----------------------------------------------------------------------------------------- -- and here a small and hopefully enlightening example: data Flag = Verbose | Version | Name String | Output String | Arg String deriving Show options :: [OptDescr Flag] options = [Option ['v'] ["verbose"] (NoArg Verbose) "verbosely list files", Option ['V','?'] ["version","release"] (NoArg Version) "show version info", Option ['o'] ["output"] (OptArg out "FILE") "use FILE for dump", Option ['n'] ["name"] (ReqArg Name "USER") "only dump USER's files"] out :: Maybe String -> Flag out Nothing = Output "stdout" out (Just o) = Output o test :: ArgOrder Flag -> [String] -> String test order cmdline = case getOpt order options cmdline of (o,n,[] ) -> "options=" ++ show o ++ " args=" ++ show n ++ "\n" (_,_,errs) -> concat errs ++ usageInfo header options where header = "Usage: foobar [OPTION...] files..." -- example runs: -- putStr (test RequireOrder ["foo","-v"]) -- ==> options=[] args=["foo", "-v"] -- putStr (test Permute ["foo","-v"]) -- ==> options=[Verbose] args=["foo"] -- putStr (test (ReturnInOrder Arg) ["foo","-v"]) -- ==> options=[Arg "foo", Verbose] args=[] -- putStr (test Permute ["foo","--","-v"]) -- ==> options=[] args=["foo", "-v"] -- putStr (test Permute ["-?o","--name","bar","--na=baz"]) -- ==> options=[Version, Output "stdout", Name "bar", Name "baz"] args=[] -- putStr (test Permute ["--ver","foo"]) -- ==> option `--ver' is ambiguous; could be one of: -- -v --verbose verbosely list files -- -V, -? --version, --release show version info -- Usage: foobar [OPTION...] files... -- -v --verbose verbosely list files -- -V, -? --version, --release show version info -- -o[FILE] --output[=FILE] use FILE for dump -- -n USER --name=USER only dump USER's files ----------------------------------------------------------------------------------------- -} {- $example To hopefully illuminate the role of the different data structures, here\'s the command-line options for a (very simple) compiler: > module Opts where > > import Distribution.GetOpt > import Data.Maybe ( fromMaybe ) > > data Flag > = Verbose | Version > | Input String | Output String | LibDir String > deriving Show > > options :: [OptDescr Flag] > options = > [ Option ['v'] ["verbose"] (NoArg Verbose) "chatty output on stderr" > , Option ['V','?'] ["version"] (NoArg Version) "show version number" > , Option ['o'] ["output"] (OptArg outp "FILE") "output FILE" > , Option ['c'] [] (OptArg inp "FILE") "input FILE" > , Option ['L'] ["libdir"] (ReqArg LibDir "DIR") "library directory" > ] > > inp,outp :: Maybe String -> Flag > outp = Output . fromMaybe "stdout" > inp = Input . fromMaybe "stdin" > > compilerOpts :: [String] -> IO ([Flag], [String]) > compilerOpts argv = > case getOpt Permute options argv of > (o,n,[] ) -> return (o,n) > (_,_,errs) -> ioError (userError (concat errs ++ usageInfo header options)) > where header = "Usage: ic [OPTION...] files..." -} Cabal-1.22.5.0/Distribution/InstalledPackageInfo.hs0000644000000000000000000003706112627136220020161 0ustar0000000000000000{-# LANGUAGE DeriveGeneric #-} ----------------------------------------------------------------------------- -- | -- Module : Distribution.InstalledPackageInfo -- Copyright : (c) The University of Glasgow 2004 -- -- Maintainer : libraries@haskell.org -- Portability : portable -- -- This is the information about an /installed/ package that -- is communicated to the @ghc-pkg@ program in order to register -- a package. @ghc-pkg@ now consumes this package format (as of version -- 6.4). This is specific to GHC at the moment. -- -- The @.cabal@ file format is for describing a package that is not yet -- installed. It has a lot of flexibility, like conditionals and dependency -- ranges. As such, that format is not at all suitable for describing a package -- that has already been built and installed. By the time we get to that stage, -- we have resolved all conditionals and resolved dependency version -- constraints to exact versions of dependent packages. So, this module defines -- the 'InstalledPackageInfo' data structure that contains all the info we keep -- about an installed package. There is a parser and pretty printer. The -- textual format is rather simpler than the @.cabal@ format: there are no -- sections, for example. -- This module is meant to be local-only to Distribution... module Distribution.InstalledPackageInfo ( InstalledPackageInfo_(..), InstalledPackageInfo, OriginalModule(..), ExposedModule(..), ParseResult(..), PError(..), PWarning, emptyInstalledPackageInfo, parseInstalledPackageInfo, showInstalledPackageInfo, showInstalledPackageInfoField, showSimpleInstalledPackageInfoField, fieldsInstalledPackageInfo, ) where import Distribution.ParseUtils ( FieldDescr(..), ParseResult(..), PError(..), PWarning , simpleField, listField, parseLicenseQ , showFields, showSingleNamedField, showSimpleSingleNamedField , parseFieldsFlat , parseFilePathQ, parseTokenQ, parseModuleNameQ, parsePackageNameQ , showFilePath, showToken, boolField, parseOptVersion , parseFreeText, showFreeText, parseOptCommaList ) import Distribution.License ( License(..) ) import Distribution.Package ( PackageName(..), PackageIdentifier(..) , PackageId, InstalledPackageId(..) , packageName, packageVersion, PackageKey(..) ) import qualified Distribution.Package as Package import Distribution.ModuleName ( ModuleName ) import Distribution.Version ( Version(..) ) import Distribution.Text ( Text(disp, parse) ) import Text.PrettyPrint as Disp import qualified Distribution.Compat.ReadP as Parse import Distribution.Compat.Binary (Binary) import Data.Maybe (fromMaybe) import GHC.Generics (Generic) -- ----------------------------------------------------------------------------- -- The InstalledPackageInfo type data InstalledPackageInfo_ m = InstalledPackageInfo { -- these parts are exactly the same as PackageDescription installedPackageId :: InstalledPackageId, sourcePackageId :: PackageId, packageKey :: PackageKey, license :: License, copyright :: String, maintainer :: String, author :: String, stability :: String, homepage :: String, pkgUrl :: String, synopsis :: String, description :: String, category :: String, -- these parts are required by an installed package only: exposed :: Bool, exposedModules :: [ExposedModule], instantiatedWith :: [(m, OriginalModule)], hiddenModules :: [m], trusted :: Bool, importDirs :: [FilePath], libraryDirs :: [FilePath], dataDir :: FilePath, hsLibraries :: [String], extraLibraries :: [String], extraGHCiLibraries:: [String], -- overrides extraLibraries for GHCi includeDirs :: [FilePath], includes :: [String], depends :: [InstalledPackageId], ccOptions :: [String], ldOptions :: [String], frameworkDirs :: [FilePath], frameworks :: [String], haddockInterfaces :: [FilePath], haddockHTMLs :: [FilePath], pkgRoot :: Maybe FilePath } deriving (Generic, Read, Show) instance Binary m => Binary (InstalledPackageInfo_ m) instance Package.Package (InstalledPackageInfo_ str) where packageId = sourcePackageId instance Package.PackageInstalled (InstalledPackageInfo_ str) where installedPackageId = installedPackageId installedDepends = depends type InstalledPackageInfo = InstalledPackageInfo_ ModuleName emptyInstalledPackageInfo :: InstalledPackageInfo_ m emptyInstalledPackageInfo = InstalledPackageInfo { installedPackageId = InstalledPackageId "", sourcePackageId = PackageIdentifier (PackageName "") noVersion, packageKey = OldPackageKey (PackageIdentifier (PackageName "") noVersion), license = UnspecifiedLicense, copyright = "", maintainer = "", author = "", stability = "", homepage = "", pkgUrl = "", synopsis = "", description = "", category = "", exposed = False, exposedModules = [], hiddenModules = [], instantiatedWith = [], trusted = False, importDirs = [], libraryDirs = [], dataDir = "", hsLibraries = [], extraLibraries = [], extraGHCiLibraries= [], includeDirs = [], includes = [], depends = [], ccOptions = [], ldOptions = [], frameworkDirs = [], frameworks = [], haddockInterfaces = [], haddockHTMLs = [], pkgRoot = Nothing } noVersion :: Version noVersion = Version [] [] -- ----------------------------------------------------------------------------- -- Exposed modules data OriginalModule = OriginalModule { originalPackageId :: InstalledPackageId, originalModuleName :: ModuleName } deriving (Generic, Eq, Read, Show) data ExposedModule = ExposedModule { exposedName :: ModuleName, exposedReexport :: Maybe OriginalModule, exposedSignature :: Maybe OriginalModule -- This field is unused for now. } deriving (Generic, Read, Show) instance Text OriginalModule where disp (OriginalModule ipi m) = disp ipi <> Disp.char ':' <> disp m parse = do ipi <- parse _ <- Parse.char ':' m <- parse return (OriginalModule ipi m) instance Text ExposedModule where disp (ExposedModule m reexport signature) = Disp.sep [ disp m , case reexport of Just m' -> Disp.sep [Disp.text "from", disp m'] Nothing -> Disp.empty , case signature of Just m' -> Disp.sep [Disp.text "is", disp m'] Nothing -> Disp.empty ] parse = do m <- parseModuleNameQ Parse.skipSpaces reexport <- Parse.option Nothing $ do _ <- Parse.string "from" Parse.skipSpaces fmap Just parse Parse.skipSpaces signature <- Parse.option Nothing $ do _ <- Parse.string "is" Parse.skipSpaces fmap Just parse return (ExposedModule m reexport signature) instance Binary OriginalModule instance Binary ExposedModule -- To maintain backwards-compatibility, we accept both comma/non-comma -- separated variants of this field. You SHOULD use the comma syntax if you -- use any new functions, although actually it's unambiguous due to a quirk -- of the fact that modules must start with capital letters. showExposedModules :: [ExposedModule] -> Disp.Doc showExposedModules xs | all isExposedModule xs = fsep (map disp xs) | otherwise = fsep (Disp.punctuate comma (map disp xs)) where isExposedModule (ExposedModule _ Nothing Nothing) = True isExposedModule _ = False parseExposedModules :: Parse.ReadP r [ExposedModule] parseExposedModules = parseOptCommaList parse -- ----------------------------------------------------------------------------- -- Parsing parseInstalledPackageInfo :: String -> ParseResult InstalledPackageInfo parseInstalledPackageInfo = parseFieldsFlat (fieldsInstalledPackageInfo ++ deprecatedFieldDescrs) emptyInstalledPackageInfo parseInstantiatedWith :: Parse.ReadP r (ModuleName, OriginalModule) parseInstantiatedWith = do k <- parse _ <- Parse.char '=' n <- parse _ <- Parse.char '@' p <- parse return (k, OriginalModule p n) -- ----------------------------------------------------------------------------- -- Pretty-printing showInstalledPackageInfo :: InstalledPackageInfo -> String showInstalledPackageInfo = showFields fieldsInstalledPackageInfo showInstalledPackageInfoField :: String -> Maybe (InstalledPackageInfo -> String) showInstalledPackageInfoField = showSingleNamedField fieldsInstalledPackageInfo showSimpleInstalledPackageInfoField :: String -> Maybe (InstalledPackageInfo -> String) showSimpleInstalledPackageInfoField = showSimpleSingleNamedField fieldsInstalledPackageInfo showInstantiatedWith :: (ModuleName, OriginalModule) -> Doc showInstantiatedWith (k, OriginalModule p m) = disp k <> text "=" <> disp m <> text "@" <> disp p -- ----------------------------------------------------------------------------- -- Description of the fields, for parsing/printing fieldsInstalledPackageInfo :: [FieldDescr InstalledPackageInfo] fieldsInstalledPackageInfo = basicFieldDescrs ++ installedFieldDescrs basicFieldDescrs :: [FieldDescr InstalledPackageInfo] basicFieldDescrs = [ simpleField "name" disp parsePackageNameQ packageName (\name pkg -> pkg{sourcePackageId=(sourcePackageId pkg){pkgName=name}}) , simpleField "version" disp parseOptVersion packageVersion (\ver pkg -> pkg{sourcePackageId=(sourcePackageId pkg){pkgVersion=ver}}) , simpleField "id" disp parse installedPackageId (\ipid pkg -> pkg{installedPackageId=ipid}) , simpleField "key" disp parse packageKey (\ipid pkg -> pkg{packageKey=ipid}) , simpleField "license" disp parseLicenseQ license (\l pkg -> pkg{license=l}) , simpleField "copyright" showFreeText parseFreeText copyright (\val pkg -> pkg{copyright=val}) , simpleField "maintainer" showFreeText parseFreeText maintainer (\val pkg -> pkg{maintainer=val}) , simpleField "stability" showFreeText parseFreeText stability (\val pkg -> pkg{stability=val}) , simpleField "homepage" showFreeText parseFreeText homepage (\val pkg -> pkg{homepage=val}) , simpleField "package-url" showFreeText parseFreeText pkgUrl (\val pkg -> pkg{pkgUrl=val}) , simpleField "synopsis" showFreeText parseFreeText synopsis (\val pkg -> pkg{synopsis=val}) , simpleField "description" showFreeText parseFreeText description (\val pkg -> pkg{description=val}) , simpleField "category" showFreeText parseFreeText category (\val pkg -> pkg{category=val}) , simpleField "author" showFreeText parseFreeText author (\val pkg -> pkg{author=val}) ] installedFieldDescrs :: [FieldDescr InstalledPackageInfo] installedFieldDescrs = [ boolField "exposed" exposed (\val pkg -> pkg{exposed=val}) , simpleField "exposed-modules" showExposedModules parseExposedModules exposedModules (\xs pkg -> pkg{exposedModules=xs}) , listField "hidden-modules" disp parseModuleNameQ hiddenModules (\xs pkg -> pkg{hiddenModules=xs}) , listField "instantiated-with" showInstantiatedWith parseInstantiatedWith instantiatedWith (\xs pkg -> pkg{instantiatedWith=xs}) , boolField "trusted" trusted (\val pkg -> pkg{trusted=val}) , listField "import-dirs" showFilePath parseFilePathQ importDirs (\xs pkg -> pkg{importDirs=xs}) , listField "library-dirs" showFilePath parseFilePathQ libraryDirs (\xs pkg -> pkg{libraryDirs=xs}) , simpleField "data-dir" showFilePath (parseFilePathQ Parse.<++ return "") dataDir (\val pkg -> pkg{dataDir=val}) , listField "hs-libraries" showFilePath parseTokenQ hsLibraries (\xs pkg -> pkg{hsLibraries=xs}) , listField "extra-libraries" showToken parseTokenQ extraLibraries (\xs pkg -> pkg{extraLibraries=xs}) , listField "extra-ghci-libraries" showToken parseTokenQ extraGHCiLibraries (\xs pkg -> pkg{extraGHCiLibraries=xs}) , listField "include-dirs" showFilePath parseFilePathQ includeDirs (\xs pkg -> pkg{includeDirs=xs}) , listField "includes" showFilePath parseFilePathQ includes (\xs pkg -> pkg{includes=xs}) , listField "depends" disp parse depends (\xs pkg -> pkg{depends=xs}) , listField "cc-options" showToken parseTokenQ ccOptions (\path pkg -> pkg{ccOptions=path}) , listField "ld-options" showToken parseTokenQ ldOptions (\path pkg -> pkg{ldOptions=path}) , listField "framework-dirs" showFilePath parseFilePathQ frameworkDirs (\xs pkg -> pkg{frameworkDirs=xs}) , listField "frameworks" showToken parseTokenQ frameworks (\xs pkg -> pkg{frameworks=xs}) , listField "haddock-interfaces" showFilePath parseFilePathQ haddockInterfaces (\xs pkg -> pkg{haddockInterfaces=xs}) , listField "haddock-html" showFilePath parseFilePathQ haddockHTMLs (\xs pkg -> pkg{haddockHTMLs=xs}) , simpleField "pkgroot" (const Disp.empty) parseFilePathQ (fromMaybe "" . pkgRoot) (\xs pkg -> pkg{pkgRoot=Just xs}) ] deprecatedFieldDescrs :: [FieldDescr InstalledPackageInfo] deprecatedFieldDescrs = [ listField "hugs-options" showToken parseTokenQ (const []) (const id) ] Cabal-1.22.5.0/Distribution/License.hs0000644000000000000000000001601112627136220015524 0ustar0000000000000000{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-} ----------------------------------------------------------------------------- -- | -- Module : Distribution.License -- Description : The License data type. -- Copyright : Isaac Jones 2003-2005 -- Duncan Coutts 2008 -- License : BSD3 -- -- Maintainer : cabal-devel@haskell.org -- Portability : portable -- -- Package descriptions contain fields for specifying the name of a software -- license and the name of the file containing the text of that license. While -- package authors may choose any license they like, Cabal provides an -- enumeration of a small set of common free and open source software licenses. -- This is done so that Hackage can recognise licenses, so that tools can detect -- , -- and to deter -- . -- -- It is recommended that all package authors use the @license-file@ or -- @license-files@ fields in their package descriptions. Further information -- about these fields can be found in the -- . -- -- = Additional resources -- -- The following websites provide information about free and open source -- software licenses: -- -- * -- -- * -- -- = Disclaimer -- -- The descriptions of software licenses provided by this documentation are -- intended for informational purposes only and in no way constitute legal -- advice. Please read the text of the licenses and consult a lawyer for any -- advice regarding software licensing. module Distribution.License ( License(..), knownLicenses, ) where import Distribution.Version (Version(Version)) import Distribution.Text (Text(..), display) import qualified Distribution.Compat.ReadP as Parse import qualified Text.PrettyPrint as Disp import Text.PrettyPrint ((<>)) import Distribution.Compat.Binary (Binary) import qualified Data.Char as Char (isAlphaNum) import Data.Data (Data) import Data.Typeable (Typeable) import GHC.Generics (Generic) -- | Indicates the license under which a package's source code is released. -- Versions of the licenses not listed here will be rejected by Hackage and -- cause @cabal check@ to issue a warning. data License = -- TODO: * remove BSD4 -- | GNU General Public License, -- or -- . GPL (Maybe Version) -- | . | AGPL (Maybe Version) -- | GNU Lesser General Public License, -- or -- . | LGPL (Maybe Version) -- | . | BSD2 -- | . | BSD3 -- | . -- This license has not been approved by the OSI and is incompatible with -- the GNU GPL. It is provided for historical reasons and should be avoided. | BSD4 -- | . | MIT -- | | ISC -- | . | MPL Version -- | . | Apache (Maybe Version) -- | The author of a package disclaims any copyright to its source code and -- dedicates it to the public domain. This is not a software license. Please -- note that it is not possible to dedicate works to the public domain in -- every jurisdiction, nor is a work that is in the public domain in one -- jurisdiction necessarily in the public domain elsewhere. | PublicDomain -- | Explicitly 'All Rights Reserved', eg for proprietary software. The -- package may not be legally modified or redistributed by anyone but the -- rightsholder. | AllRightsReserved -- | No license specified which legally defaults to 'All Rights Reserved'. -- The package may not be legally modified or redistributed by anyone but -- the rightsholder. | UnspecifiedLicense -- | Any other software license. | OtherLicense -- | Indicates an erroneous license name. | UnknownLicense String deriving (Generic, Read, Show, Eq, Typeable, Data) instance Binary License -- | The list of all currently recognised licenses. knownLicenses :: [License] knownLicenses = [ GPL unversioned, GPL (version [2]), GPL (version [3]) , LGPL unversioned, LGPL (version [2, 1]), LGPL (version [3]) , AGPL unversioned, AGPL (version [3]) , BSD2, BSD3, MIT, ISC , MPL (Version [2, 0] []) , Apache unversioned, Apache (version [2, 0]) , PublicDomain, AllRightsReserved, OtherLicense] where unversioned = Nothing version v = Just (Version v []) instance Text License where disp (GPL version) = Disp.text "GPL" <> dispOptVersion version disp (LGPL version) = Disp.text "LGPL" <> dispOptVersion version disp (AGPL version) = Disp.text "AGPL" <> dispOptVersion version disp (MPL version) = Disp.text "MPL" <> dispVersion version disp (Apache version) = Disp.text "Apache" <> dispOptVersion version disp (UnknownLicense other) = Disp.text other disp other = Disp.text (show other) parse = do name <- Parse.munch1 (\c -> Char.isAlphaNum c && c /= '-') version <- Parse.option Nothing (Parse.char '-' >> fmap Just parse) return $! case (name, version :: Maybe Version) of ("GPL", _ ) -> GPL version ("LGPL", _ ) -> LGPL version ("AGPL", _ ) -> AGPL version ("BSD2", Nothing) -> BSD2 ("BSD3", Nothing) -> BSD3 ("BSD4", Nothing) -> BSD4 ("ISC", Nothing) -> ISC ("MIT", Nothing) -> MIT ("MPL", Just version') -> MPL version' ("Apache", _ ) -> Apache version ("PublicDomain", Nothing) -> PublicDomain ("AllRightsReserved", Nothing) -> AllRightsReserved ("OtherLicense", Nothing) -> OtherLicense _ -> UnknownLicense $ name ++ maybe "" (('-':) . display) version dispOptVersion :: Maybe Version -> Disp.Doc dispOptVersion Nothing = Disp.empty dispOptVersion (Just v) = dispVersion v dispVersion :: Version -> Disp.Doc dispVersion v = Disp.char '-' <> disp v Cabal-1.22.5.0/Distribution/Make.hs0000644000000000000000000001603712627136220015027 0ustar0000000000000000----------------------------------------------------------------------------- -- | -- Module : Distribution.Make -- Copyright : Martin Sjögren 2004 -- License : BSD3 -- -- Maintainer : cabal-devel@haskell.org -- Portability : portable -- -- This is an alternative build system that delegates everything to the @make@ -- program. All the commands just end up calling @make@ with appropriate -- arguments. The intention was to allow preexisting packages that used -- makefiles to be wrapped into Cabal packages. In practice essentially all -- such packages were converted over to the \"Simple\" build system instead. -- Consequently this module is not used much and it certainly only sees cursory -- maintenance and no testing. Perhaps at some point we should stop pretending -- that it works. -- -- Uses the parsed command-line from "Distribution.Simple.Setup" in order to build -- Haskell tools using a back-end build system based on make. Obviously we -- assume that there is a configure script, and that after the ConfigCmd has -- been run, there is a Makefile. Further assumptions: -- -- [ConfigCmd] We assume the configure script accepts -- @--with-hc@, -- @--with-hc-pkg@, -- @--prefix@, -- @--bindir@, -- @--libdir@, -- @--libexecdir@, -- @--datadir@. -- -- [BuildCmd] We assume that the default Makefile target will build everything. -- -- [InstallCmd] We assume there is an @install@ target. Note that we assume that -- this does *not* register the package! -- -- [CopyCmd] We assume there is a @copy@ target, and a variable @$(destdir)@. -- The @copy@ target should probably just invoke @make install@ -- recursively (e.g. @$(MAKE) install prefix=$(destdir)\/$(prefix) -- bindir=$(destdir)\/$(bindir)@. The reason we can\'t invoke @make -- install@ directly here is that we don\'t know the value of @$(prefix)@. -- -- [SDistCmd] We assume there is a @dist@ target. -- -- [RegisterCmd] We assume there is a @register@ target and a variable @$(user)@. -- -- [UnregisterCmd] We assume there is an @unregister@ target. -- -- [HaddockCmd] We assume there is a @docs@ or @doc@ target. -- copy : -- $(MAKE) install prefix=$(destdir)/$(prefix) \ -- bindir=$(destdir)/$(bindir) \ module Distribution.Make ( module Distribution.Package, License(..), Version(..), defaultMain, defaultMainArgs, defaultMainNoRead ) where -- local import Distribution.Compat.Exception import Distribution.Package --must not specify imports, since we're exporting moule. import Distribution.Simple.Program(defaultProgramConfiguration) import Distribution.PackageDescription import Distribution.Simple.Setup import Distribution.Simple.Command import Distribution.Simple.Utils (rawSystemExit, cabalVersion) import Distribution.License (License(..)) import Distribution.Version ( Version(..) ) import Distribution.Text ( display ) import System.Environment (getArgs, getProgName) import Data.List (intercalate) import System.Exit defaultMain :: IO () defaultMain = getArgs >>= defaultMainArgs defaultMainArgs :: [String] -> IO () defaultMainArgs = defaultMainHelper {-# DEPRECATED defaultMainNoRead "it ignores its PackageDescription arg" #-} defaultMainNoRead :: PackageDescription -> IO () defaultMainNoRead = const defaultMain defaultMainHelper :: [String] -> IO () defaultMainHelper args = case commandsRun (globalCommand commands) commands args of CommandHelp help -> printHelp help CommandList opts -> printOptionsList opts CommandErrors errs -> printErrors errs CommandReadyToGo (flags, commandParse) -> case commandParse of _ | fromFlag (globalVersion flags) -> printVersion | fromFlag (globalNumericVersion flags) -> printNumericVersion CommandHelp help -> printHelp help CommandList opts -> printOptionsList opts CommandErrors errs -> printErrors errs CommandReadyToGo action -> action where printHelp help = getProgName >>= putStr . help printOptionsList = putStr . unlines printErrors errs = do putStr (intercalate "\n" errs) exitWith (ExitFailure 1) printNumericVersion = putStrLn $ display cabalVersion printVersion = putStrLn $ "Cabal library version " ++ display cabalVersion progs = defaultProgramConfiguration commands = [configureCommand progs `commandAddAction` configureAction ,buildCommand progs `commandAddAction` buildAction ,installCommand `commandAddAction` installAction ,copyCommand `commandAddAction` copyAction ,haddockCommand `commandAddAction` haddockAction ,cleanCommand `commandAddAction` cleanAction ,sdistCommand `commandAddAction` sdistAction ,registerCommand `commandAddAction` registerAction ,unregisterCommand `commandAddAction` unregisterAction ] configureAction :: ConfigFlags -> [String] -> IO () configureAction flags args = do noExtraFlags args let verbosity = fromFlag (configVerbosity flags) rawSystemExit verbosity "sh" $ "configure" : configureArgs backwardsCompatHack flags where backwardsCompatHack = True copyAction :: CopyFlags -> [String] -> IO () copyAction flags args = do noExtraFlags args let destArgs = case fromFlag $ copyDest flags of NoCopyDest -> ["install"] CopyTo path -> ["copy", "destdir=" ++ path] rawSystemExit (fromFlag $ copyVerbosity flags) "make" destArgs installAction :: InstallFlags -> [String] -> IO () installAction flags args = do noExtraFlags args rawSystemExit (fromFlag $ installVerbosity flags) "make" ["install"] rawSystemExit (fromFlag $ installVerbosity flags) "make" ["register"] haddockAction :: HaddockFlags -> [String] -> IO () haddockAction flags args = do noExtraFlags args rawSystemExit (fromFlag $ haddockVerbosity flags) "make" ["docs"] `catchIO` \_ -> rawSystemExit (fromFlag $ haddockVerbosity flags) "make" ["doc"] buildAction :: BuildFlags -> [String] -> IO () buildAction flags args = do noExtraFlags args rawSystemExit (fromFlag $ buildVerbosity flags) "make" [] cleanAction :: CleanFlags -> [String] -> IO () cleanAction flags args = do noExtraFlags args rawSystemExit (fromFlag $ cleanVerbosity flags) "make" ["clean"] sdistAction :: SDistFlags -> [String] -> IO () sdistAction flags args = do noExtraFlags args rawSystemExit (fromFlag $ sDistVerbosity flags) "make" ["dist"] registerAction :: RegisterFlags -> [String] -> IO () registerAction flags args = do noExtraFlags args rawSystemExit (fromFlag $ regVerbosity flags) "make" ["register"] unregisterAction :: RegisterFlags -> [String] -> IO () unregisterAction flags args = do noExtraFlags args rawSystemExit (fromFlag $ regVerbosity flags) "make" ["unregister"] Cabal-1.22.5.0/Distribution/ModuleName.hs0000644000000000000000000000605312627136220016175 0ustar0000000000000000{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-} ----------------------------------------------------------------------------- -- | -- Module : Distribution.ModuleName -- Copyright : Duncan Coutts 2008 -- License : BSD3 -- -- Maintainer : cabal-devel@haskell.org -- Portability : portable -- -- Data type for Haskell module names. module Distribution.ModuleName ( ModuleName, fromString, components, toFilePath, main, simple, ) where import Distribution.Text ( Text(..) ) import Distribution.Compat.Binary (Binary) import qualified Data.Char as Char ( isAlphaNum, isUpper ) import Data.Data (Data) import Data.Typeable (Typeable) import qualified Distribution.Compat.ReadP as Parse import qualified Text.PrettyPrint as Disp import Data.List ( intercalate, intersperse ) import GHC.Generics (Generic) import System.FilePath ( pathSeparator ) -- | A valid Haskell module name. -- newtype ModuleName = ModuleName [String] deriving (Eq, Generic, Ord, Read, Show, Typeable, Data) instance Binary ModuleName instance Text ModuleName where disp (ModuleName ms) = Disp.hcat (intersperse (Disp.char '.') (map Disp.text ms)) parse = do ms <- Parse.sepBy1 component (Parse.char '.') return (ModuleName ms) where component = do c <- Parse.satisfy Char.isUpper cs <- Parse.munch validModuleChar return (c:cs) validModuleChar :: Char -> Bool validModuleChar c = Char.isAlphaNum c || c == '_' || c == '\'' validModuleComponent :: String -> Bool validModuleComponent [] = False validModuleComponent (c:cs) = Char.isUpper c && all validModuleChar cs {-# DEPRECATED simple "use ModuleName.fromString instead" #-} simple :: String -> ModuleName simple str = ModuleName [str] -- | Construct a 'ModuleName' from a valid module name 'String'. -- -- This is just a convenience function intended for valid module strings. It is -- an error if it is used with a string that is not a valid module name. If you -- are parsing user input then use 'Distribution.Text.simpleParse' instead. -- fromString :: String -> ModuleName fromString string | all validModuleComponent components' = ModuleName components' | otherwise = error badName where components' = split string badName = "ModuleName.fromString: invalid module name " ++ show string split cs = case break (=='.') cs of (chunk,[]) -> chunk : [] (chunk,_:rest) -> chunk : split rest -- | The module name @Main@. -- main :: ModuleName main = ModuleName ["Main"] -- | The individual components of a hierarchical module name. For example -- -- > components (fromString "A.B.C") = ["A", "B", "C"] -- components :: ModuleName -> [String] components (ModuleName ms) = ms -- | Convert a module name to a file path, but without any file extension. -- For example: -- -- > toFilePath (fromString "A.B.C") = "A/B/C" -- toFilePath :: ModuleName -> FilePath toFilePath = intercalate [pathSeparator] . components Cabal-1.22.5.0/Distribution/Package.hs0000644000000000000000000003366512627136220015513 0ustar0000000000000000{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-} ----------------------------------------------------------------------------- -- | -- Module : Distribution.Package -- Copyright : Isaac Jones 2003-2004 -- License : BSD3 -- -- Maintainer : cabal-devel@haskell.org -- Portability : portable -- -- Defines a package identifier along with a parser and pretty printer for it. -- 'PackageIdentifier's consist of a name and an exact version. It also defines -- a 'Dependency' data type. A dependency is a package name and a version -- range, like @\"foo >= 1.2 && < 2\"@. module Distribution.Package ( -- * Package ids PackageName(..), PackageIdentifier(..), PackageId, -- * Installed package identifiers InstalledPackageId(..), -- * Package keys (used for linker symbols and library name) PackageKey(..), mkPackageKey, packageKeyHash, packageKeyLibraryName, -- * Package source dependencies Dependency(..), thisPackageVersion, notThisPackageVersion, simplifyDependency, -- * Package classes Package(..), packageName, packageVersion, PackageFixedDeps(..), PackageInstalled(..), ) where import Distribution.ModuleName ( ModuleName ) import Distribution.Version ( Version(..), VersionRange, anyVersion, thisVersion , notThisVersion, simplifyVersionRange ) import Distribution.Text (Text(..), display) import qualified Distribution.Compat.ReadP as Parse import Distribution.Compat.ReadP ((<++)) import qualified Text.PrettyPrint as Disp import Control.DeepSeq (NFData(..)) import Data.Ord ( comparing ) import Distribution.Compat.Binary (Binary) import qualified Data.Char as Char ( isDigit, isAlphaNum, isUpper, isLower, ord, chr ) import Data.Data ( Data ) import Data.List ( intercalate, foldl', sortBy ) import Data.Typeable ( Typeable ) import Data.Word ( Word64 ) import GHC.Fingerprint ( Fingerprint(..), fingerprintString ) import GHC.Generics (Generic) import Numeric ( showIntAtBase ) import Text.PrettyPrint ((<>), (<+>), text) newtype PackageName = PackageName { unPackageName :: String } deriving (Generic, Read, Show, Eq, Ord, Typeable, Data) instance Binary PackageName instance Text PackageName where disp (PackageName n) = Disp.text n parse = do ns <- Parse.sepBy1 component (Parse.char '-') return (PackageName (intercalate "-" ns)) where component = do cs <- Parse.munch1 Char.isAlphaNum if all Char.isDigit cs then Parse.pfail else return cs -- each component must contain an alphabetic character, to avoid -- ambiguity in identifiers like foo-1 (the 1 is the version number). instance NFData PackageName where rnf (PackageName pkg) = rnf pkg -- | Type alias so we can use the shorter name PackageId. type PackageId = PackageIdentifier -- | The name and version of a package. data PackageIdentifier = PackageIdentifier { pkgName :: PackageName, -- ^The name of this package, eg. foo pkgVersion :: Version -- ^the version of this package, eg 1.2 } deriving (Generic, Read, Show, Eq, Ord, Typeable, Data) instance Binary PackageIdentifier instance Text PackageIdentifier where disp (PackageIdentifier n v) = case v of Version [] _ -> disp n -- if no version, don't show version. _ -> disp n <> Disp.char '-' <> disp v parse = do n <- parse v <- (Parse.char '-' >> parse) <++ return (Version [] []) return (PackageIdentifier n v) instance NFData PackageIdentifier where rnf (PackageIdentifier name version) = rnf name `seq` rnf version -- ------------------------------------------------------------ -- * Installed Package Ids -- ------------------------------------------------------------ -- | An InstalledPackageId uniquely identifies an instance of an installed -- package. There can be at most one package with a given 'InstalledPackageId' -- in a package database, or overlay of databases. -- newtype InstalledPackageId = InstalledPackageId String deriving (Generic, Read,Show,Eq,Ord,Typeable,Data) instance Binary InstalledPackageId instance Text InstalledPackageId where disp (InstalledPackageId str) = text str parse = InstalledPackageId `fmap` Parse.munch1 abi_char where abi_char c = Char.isAlphaNum c || c `elem` "-_." -- ------------------------------------------------------------ -- * Package Keys -- ------------------------------------------------------------ -- | A 'PackageKey' is the notion of "package ID" which is visible to the -- compiler. Why is this not a 'PackageId'? The 'PackageId' is a user-visible -- concept written explicity in Cabal files; on the other hand, a 'PackageKey' -- may contain, for example, information about the transitive dependency -- tree of a package. Why is this not an 'InstalledPackageId'? A 'PackageKey' -- affects the ABI because it is used for linker symbols; however, an -- 'InstalledPackageId' can be used to distinguish two ABI-compatible versions -- of a library. -- -- The key is defined to be a 128-bit MD5 hash, separated into two 64-bit -- components (the most significant component coming first) which are -- individually base-62 encoded (A-Z, a-z, 0-9). -- -- @ -- key ::= hash64 hash64 -- hash64 ::= [A-Za-z0-9]{11} -- @ -- -- The string that is hashed is specified as raw_key: -- -- @ -- raw_key ::= package_id "\n" -- holes_nl -- depends_nl -- package_id ::= package_name "-" package_version -- holes_nl ::= "" -- | hole_inst "\n" holes_nl -- hole_inst ::= modulename " " key ":" modulename -- depends_nl ::= "" -- | depend "\n" depends_nl -- depend ::= key -- @ -- -- The holes list MUST be sorted by the first modulename; the depends list -- MUST be sorted by the key. holes describes the backing implementations of -- all holes in the package; depends describes all of the build-depends of -- a package. A package key MAY be used in holes even if it is not -- mentioned in depends: depends contains STRICTLY packages which are -- textually mentioned in the package description. -- -- The trailing newline is MANDATORY. -- -- There is also a variant of package key which is prefixed by a informational -- string. This key MUST NOT be used in the computation of the hash proper, -- but it is useful for human-readable consumption. -- -- @ -- infokey ::= infostring "_" key -- infostring ::= [A-Za-z0-9-]+ -- @ -- -- For example, Cabal provides a key with the first five characters of the -- package name for linker symbols. -- data PackageKey -- | Modern package key which is a hash of the PackageId and the transitive -- dependency key. Manually inline it here so we can get the instances -- we need. Also contains a short informative string = PackageKey !String {-# UNPACK #-} !Word64 {-# UNPACK #-} !Word64 -- | Old-style package key which is just a 'PackageId'. Required because -- old versions of GHC assume that the 'sourcePackageId' recorded for an -- installed package coincides with the package key it was compiled with. | OldPackageKey !PackageId deriving (Generic, Read, Show, Eq, Ord, Typeable, Data) instance Binary PackageKey -- | Convenience function which converts a fingerprint into a new-style package -- key. fingerprintPackageKey :: String -> Fingerprint -> PackageKey fingerprintPackageKey s (Fingerprint a b) = PackageKey s a b -- | Generates a 'PackageKey' from a 'PackageId', sorted package keys of the -- immediate dependencies. mkPackageKey :: Bool -- are modern style package keys supported? -> PackageId -> [PackageKey] -- dependencies -> [(ModuleName, (PackageKey, ModuleName))] -- hole instantiations -> PackageKey mkPackageKey True pid deps holes = fingerprintPackageKey stubName . fingerprintString $ display pid ++ "\n" ++ -- NB: packageKeyHash, NOT display concat [ display m ++ " " ++ packageKeyHash p' ++ ":" ++ display m' ++ "\n" | (m, (p', m')) <- sortBy (comparing fst) holes] ++ concat [ packageKeyHash d ++ "\n" | d <- sortBy (comparing packageKeyHash) deps] where stubName = take 5 (filter (/= '-') (unPackageName (pkgName pid))) mkPackageKey False pid _ _ = OldPackageKey pid -- The base-62 code is based off of 'locators' -- ((c) Operational Dynamics Consulting, BSD3 licensed) -- Note: Instead of base-62 encoding a single 128-bit integer -- (ceil(21.49) characters), we'll base-62 a pair of 64-bit integers -- (2 * ceil(10.75) characters). Luckily for us, it's the same number of -- characters! In the long term, this should go in GHC.Fingerprint, -- but not now... -- | Size of a 64-bit word when written as a base-62 string word64Base62Len :: Int word64Base62Len = 11 -- | Converts a 64-bit word into a base-62 string toBase62 :: Word64 -> String toBase62 w = pad ++ str where pad = replicate len '0' len = word64Base62Len - length str -- 11 == ceil(64 / lg 62) str = showIntAtBase 62 represent w "" represent :: Int -> Char represent x | x < 10 = Char.chr (48 + x) | x < 36 = Char.chr (65 + x - 10) | x < 62 = Char.chr (97 + x - 36) | otherwise = error ("represent (base 62): impossible!") -- | Parses a base-62 string into a 64-bit word fromBase62 :: String -> Word64 fromBase62 ss = foldl' multiply 0 ss where value :: Char -> Int value c | Char.isDigit c = Char.ord c - 48 | Char.isUpper c = Char.ord c - 65 + 10 | Char.isLower c = Char.ord c - 97 + 36 | otherwise = error ("value (base 62): impossible!") multiply :: Word64 -> Char -> Word64 multiply acc c = acc * 62 + (fromIntegral $ value c) -- | Parses a base-62 string into a fingerprint. readBase62Fingerprint :: String -> Fingerprint readBase62Fingerprint s = Fingerprint w1 w2 where (s1,s2) = splitAt word64Base62Len s w1 = fromBase62 s1 w2 = fromBase62 (take word64Base62Len s2) packageKeyHash :: PackageKey -> String packageKeyHash (PackageKey _ w1 w2) = toBase62 w1 ++ toBase62 w2 packageKeyHash (OldPackageKey pid) = display pid packageKeyLibraryName :: PackageId -> PackageKey -> String packageKeyLibraryName pid (PackageKey _ w1 w2) = display pid ++ "-" ++ toBase62 w1 ++ toBase62 w2 packageKeyLibraryName _ (OldPackageKey pid) = display pid instance Text PackageKey where disp (PackageKey prefix w1 w2) = Disp.text prefix <> Disp.char '_' <> Disp.text (toBase62 w1) <> Disp.text (toBase62 w2) disp (OldPackageKey pid) = disp pid parse = parseNew <++ parseOld where parseNew = do prefix <- Parse.munch1 (\c -> Char.isAlphaNum c || c `elem` "-") _ <- Parse.char '_' -- if we use '-' it's ambiguous fmap (fingerprintPackageKey prefix . readBase62Fingerprint) . Parse.count (word64Base62Len * 2) $ Parse.satisfy Char.isAlphaNum parseOld = do pid <- parse return (OldPackageKey pid) instance NFData PackageKey where rnf (PackageKey prefix _ _) = rnf prefix rnf (OldPackageKey pid) = rnf pid -- ------------------------------------------------------------ -- * Package source dependencies -- ------------------------------------------------------------ -- | Describes a dependency on a source package (API) -- data Dependency = Dependency PackageName VersionRange deriving (Generic, Read, Show, Eq, Typeable, Data) instance Binary Dependency instance Text Dependency where disp (Dependency name ver) = disp name <+> disp ver parse = do name <- parse Parse.skipSpaces ver <- parse <++ return anyVersion Parse.skipSpaces return (Dependency name ver) thisPackageVersion :: PackageIdentifier -> Dependency thisPackageVersion (PackageIdentifier n v) = Dependency n (thisVersion v) notThisPackageVersion :: PackageIdentifier -> Dependency notThisPackageVersion (PackageIdentifier n v) = Dependency n (notThisVersion v) -- | Simplify the 'VersionRange' expression in a 'Dependency'. -- See 'simplifyVersionRange'. -- simplifyDependency :: Dependency -> Dependency simplifyDependency (Dependency name range) = Dependency name (simplifyVersionRange range) -- | Class of things that have a 'PackageIdentifier' -- -- Types in this class are all notions of a package. This allows us to have -- different types for the different phases that packages go though, from -- simple name\/id, package description, configured or installed packages. -- -- Not all kinds of packages can be uniquely identified by a -- 'PackageIdentifier'. In particular, installed packages cannot, there may be -- many installed instances of the same source package. -- class Package pkg where packageId :: pkg -> PackageIdentifier packageName :: Package pkg => pkg -> PackageName packageName = pkgName . packageId packageVersion :: Package pkg => pkg -> Version packageVersion = pkgVersion . packageId instance Package PackageIdentifier where packageId = id -- | Subclass of packages that have specific versioned dependencies. -- -- So for example a not-yet-configured package has dependencies on version -- ranges, not specific versions. A configured or an already installed package -- depends on exact versions. Some operations or data structures (like -- dependency graphs) only make sense on this subclass of package types. -- class Package pkg => PackageFixedDeps pkg where depends :: pkg -> [PackageIdentifier] -- | Class of installed packages. -- -- The primary data type which is an instance of this package is -- 'InstalledPackageInfo', but when we are doing install plans in Cabal install -- we may have other, installed package-like things which contain more metadata. -- Installed packages have exact dependencies 'installedDepends'. class Package pkg => PackageInstalled pkg where installedPackageId :: pkg -> InstalledPackageId installedDepends :: pkg -> [InstalledPackageId] Cabal-1.22.5.0/Distribution/PackageDescription.hs0000644000000000000000000013012712627136220017706 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-} ----------------------------------------------------------------------------- -- | -- Module : Distribution.PackageDescription -- Copyright : Isaac Jones 2003-2005 -- License : BSD3 -- -- Maintainer : cabal-devel@haskell.org -- Portability : portable -- -- This defines the data structure for the @.cabal@ file format. There are -- several parts to this structure. It has top level info and then 'Library', -- 'Executable', 'TestSuite', and 'Benchmark' sections each of which have -- associated 'BuildInfo' data that's used to build the library, exe, test, or -- benchmark. To further complicate things there is both a 'PackageDescription' -- and a 'GenericPackageDescription'. This distinction relates to cabal -- configurations. When we initially read a @.cabal@ file we get a -- 'GenericPackageDescription' which has all the conditional sections. -- Before actually building a package we have to decide -- on each conditional. Once we've done that we get a 'PackageDescription'. -- It was done this way initially to avoid breaking too much stuff when the -- feature was introduced. It could probably do with being rationalised at some -- point to make it simpler. module Distribution.PackageDescription ( -- * Package descriptions PackageDescription(..), emptyPackageDescription, specVersion, descCabalVersion, BuildType(..), knownBuildTypes, -- ** Renaming ModuleRenaming(..), defaultRenaming, lookupRenaming, -- ** Libraries Library(..), ModuleReexport(..), emptyLibrary, withLib, hasLibs, libModules, -- ** Executables Executable(..), emptyExecutable, withExe, hasExes, exeModules, -- * Tests TestSuite(..), TestSuiteInterface(..), TestType(..), testType, knownTestTypes, emptyTestSuite, hasTests, withTest, testModules, enabledTests, -- * Benchmarks Benchmark(..), BenchmarkInterface(..), BenchmarkType(..), benchmarkType, knownBenchmarkTypes, emptyBenchmark, hasBenchmarks, withBenchmark, benchmarkModules, enabledBenchmarks, -- * Build information BuildInfo(..), emptyBuildInfo, allBuildInfo, allLanguages, allExtensions, usedExtensions, hcOptions, hcProfOptions, hcSharedOptions, -- ** Supplementary build information HookedBuildInfo, emptyHookedBuildInfo, updatePackageDescription, -- * package configuration GenericPackageDescription(..), Flag(..), FlagName(..), FlagAssignment, CondTree(..), ConfVar(..), Condition(..), -- * Source repositories SourceRepo(..), RepoKind(..), RepoType(..), knownRepoTypes, ) where import Distribution.Compat.Binary (Binary) import Data.Data (Data) import Data.List (nub, intercalate) import Data.Maybe (fromMaybe, maybeToList) #if __GLASGOW_HASKELL__ < 710 import Data.Monoid (Monoid(mempty, mappend)) #endif import Data.Typeable ( Typeable ) import Control.Monad (MonadPlus(mplus)) import GHC.Generics (Generic) import Text.PrettyPrint as Disp import qualified Distribution.Compat.ReadP as Parse import Distribution.Compat.ReadP ((<++)) import qualified Data.Char as Char (isAlphaNum, isDigit, toLower) import qualified Data.Map as Map import Data.Map (Map) import Distribution.Package ( PackageName(PackageName), PackageIdentifier(PackageIdentifier) , Dependency, Package(..), PackageName, packageName ) import Distribution.ModuleName ( ModuleName ) import Distribution.Version ( Version(Version), VersionRange, anyVersion, orLaterVersion , asVersionIntervals, LowerBound(..) ) import Distribution.License (License(UnspecifiedLicense)) import Distribution.Compiler (CompilerFlavor) import Distribution.System (OS, Arch) import Distribution.Text ( Text(..), display ) import Language.Haskell.Extension ( Language, Extension ) -- ----------------------------------------------------------------------------- -- The PackageDescription type -- | This data type is the internal representation of the file @pkg.cabal@. -- It contains two kinds of information about the package: information -- which is needed for all packages, such as the package name and version, and -- information which is needed for the simple build system only, such as -- the compiler options and library name. -- data PackageDescription = PackageDescription { -- the following are required by all packages: package :: PackageIdentifier, license :: License, licenseFiles :: [FilePath], copyright :: String, maintainer :: String, author :: String, stability :: String, testedWith :: [(CompilerFlavor,VersionRange)], homepage :: String, pkgUrl :: String, bugReports :: String, sourceRepos :: [SourceRepo], synopsis :: String, -- ^A one-line summary of this package description :: String, -- ^A more verbose description of this package category :: String, customFieldsPD :: [(String,String)], -- ^Custom fields starting -- with x-, stored in a -- simple assoc-list. -- | YOU PROBABLY DON'T WANT TO USE THIS FIELD. This field is -- special! Depending on how far along processing the -- PackageDescription we are, the contents of this field are -- either nonsense, or the collected dependencies of *all* the -- components in this package. buildDepends is initialized by -- 'finalizePackageDescription' and 'flattenPackageDescription'; -- prior to that, dependency info is stored in the 'CondTree' -- built around a 'GenericPackageDescription'. When this -- resolution is done, dependency info is written to the inner -- 'BuildInfo' and this field. This is all horrible, and #2066 -- tracks progress to get rid of this field. buildDepends :: [Dependency], -- | The version of the Cabal spec that this package description uses. -- For historical reasons this is specified with a version range but -- only ranges of the form @>= v@ make sense. We are in the process of -- transitioning to specifying just a single version, not a range. specVersionRaw :: Either Version VersionRange, buildType :: Maybe BuildType, -- components library :: Maybe Library, executables :: [Executable], testSuites :: [TestSuite], benchmarks :: [Benchmark], dataFiles :: [FilePath], dataDir :: FilePath, extraSrcFiles :: [FilePath], extraTmpFiles :: [FilePath], extraDocFiles :: [FilePath] } deriving (Generic, Show, Read, Eq, Typeable, Data) instance Binary PackageDescription instance Package PackageDescription where packageId = package -- | The version of the Cabal spec that this package should be interpreted -- against. -- -- Historically we used a version range but we are switching to using a single -- version. Currently we accept either. This function converts into a single -- version by ignoring upper bounds in the version range. -- specVersion :: PackageDescription -> Version specVersion pkg = case specVersionRaw pkg of Left version -> version Right versionRange -> case asVersionIntervals versionRange of [] -> Version [0] [] ((LowerBound version _, _):_) -> version -- | The range of versions of the Cabal tools that this package is intended to -- work with. -- -- This function is deprecated and should not be used for new purposes, only to -- support old packages that rely on the old interpretation. -- descCabalVersion :: PackageDescription -> VersionRange descCabalVersion pkg = case specVersionRaw pkg of Left version -> orLaterVersion version Right versionRange -> versionRange {-# DEPRECATED descCabalVersion "Use specVersion instead" #-} emptyPackageDescription :: PackageDescription emptyPackageDescription = PackageDescription { package = PackageIdentifier (PackageName "") (Version [] []), license = UnspecifiedLicense, licenseFiles = [], specVersionRaw = Right anyVersion, buildType = Nothing, copyright = "", maintainer = "", author = "", stability = "", testedWith = [], buildDepends = [], homepage = "", pkgUrl = "", bugReports = "", sourceRepos = [], synopsis = "", description = "", category = "", customFieldsPD = [], library = Nothing, executables = [], testSuites = [], benchmarks = [], dataFiles = [], dataDir = "", extraSrcFiles = [], extraTmpFiles = [], extraDocFiles = [] } -- | The type of build system used by this package. data BuildType = Simple -- ^ calls @Distribution.Simple.defaultMain@ | Configure -- ^ calls @Distribution.Simple.defaultMainWithHooks defaultUserHooks@, -- which invokes @configure@ to generate additional build -- information used by later phases. | Make -- ^ calls @Distribution.Make.defaultMain@ | Custom -- ^ uses user-supplied @Setup.hs@ or @Setup.lhs@ (default) | UnknownBuildType String -- ^ a package that uses an unknown build type cannot actually -- be built. Doing it this way rather than just giving a -- parse error means we get better error messages and allows -- you to inspect the rest of the package description. deriving (Generic, Show, Read, Eq, Typeable, Data) instance Binary BuildType knownBuildTypes :: [BuildType] knownBuildTypes = [Simple, Configure, Make, Custom] instance Text BuildType where disp (UnknownBuildType other) = Disp.text other disp other = Disp.text (show other) parse = do name <- Parse.munch1 Char.isAlphaNum return $ case name of "Simple" -> Simple "Configure" -> Configure "Custom" -> Custom "Make" -> Make _ -> UnknownBuildType name -- --------------------------------------------------------------------------- -- Module renaming -- | Renaming applied to the modules provided by a package. -- The boolean indicates whether or not to also include all of the -- original names of modules. Thus, @ModuleRenaming False []@ is -- "don't expose any modules, and @ModuleRenaming True [("Data.Bool", "Bool")]@ -- is, "expose all modules, but also expose @Data.Bool@ as @Bool@". -- data ModuleRenaming = ModuleRenaming Bool [(ModuleName, ModuleName)] deriving (Show, Read, Eq, Ord, Typeable, Data, Generic) defaultRenaming :: ModuleRenaming defaultRenaming = ModuleRenaming True [] lookupRenaming :: Package pkg => pkg -> Map PackageName ModuleRenaming -> ModuleRenaming lookupRenaming pkg rns = Map.findWithDefault (error ("lookupRenaming: missing renaming for " ++ display (packageName pkg))) (packageName pkg) rns instance Binary ModuleRenaming where instance Monoid ModuleRenaming where ModuleRenaming b rns `mappend` ModuleRenaming b' rns' = ModuleRenaming (b || b') (rns ++ rns') -- ToDo: dedupe? mempty = ModuleRenaming False [] -- NB: parentheses are mandatory, because later we may extend this syntax -- to allow "hiding (A, B)" or other modifier words. instance Text ModuleRenaming where disp (ModuleRenaming True []) = Disp.empty disp (ModuleRenaming b vs) = (if b then text "with" else Disp.empty) <+> dispRns where dispRns = Disp.parens (Disp.hsep (Disp.punctuate Disp.comma (map dispEntry vs))) dispEntry (orig, new) | orig == new = disp orig | otherwise = disp orig <+> text "as" <+> disp new parse = do Parse.string "with" >> Parse.skipSpaces fmap (ModuleRenaming True) parseRns <++ fmap (ModuleRenaming False) parseRns <++ return (ModuleRenaming True []) where parseRns = do rns <- Parse.between (Parse.char '(') (Parse.char ')') parseList Parse.skipSpaces return rns parseList = Parse.sepBy parseEntry (Parse.char ',' >> Parse.skipSpaces) parseEntry :: Parse.ReadP r (ModuleName, ModuleName) parseEntry = do orig <- parse Parse.skipSpaces (do _ <- Parse.string "as" Parse.skipSpaces new <- parse Parse.skipSpaces return (orig, new) <++ return (orig, orig)) -- --------------------------------------------------------------------------- -- The Library type data Library = Library { exposedModules :: [ModuleName], reexportedModules :: [ModuleReexport], requiredSignatures:: [ModuleName], -- ^ What sigs need implementations? exposedSignatures:: [ModuleName], -- ^ What sigs are visible to users? libExposed :: Bool, -- ^ Is the lib to be exposed by default? libBuildInfo :: BuildInfo } deriving (Generic, Show, Eq, Read, Typeable, Data) instance Binary Library instance Monoid Library where mempty = Library { exposedModules = mempty, reexportedModules = mempty, requiredSignatures = mempty, exposedSignatures = mempty, libExposed = True, libBuildInfo = mempty } mappend a b = Library { exposedModules = combine exposedModules, reexportedModules = combine reexportedModules, requiredSignatures = combine requiredSignatures, exposedSignatures = combine exposedSignatures, libExposed = libExposed a && libExposed b, -- so False propagates libBuildInfo = combine libBuildInfo } where combine field = field a `mappend` field b emptyLibrary :: Library emptyLibrary = mempty -- |does this package have any libraries? hasLibs :: PackageDescription -> Bool hasLibs p = maybe False (buildable . libBuildInfo) (library p) -- |'Maybe' version of 'hasLibs' maybeHasLibs :: PackageDescription -> Maybe Library maybeHasLibs p = library p >>= \lib -> if buildable (libBuildInfo lib) then Just lib else Nothing -- |If the package description has a library section, call the given -- function with the library build info as argument. withLib :: PackageDescription -> (Library -> IO ()) -> IO () withLib pkg_descr f = maybe (return ()) f (maybeHasLibs pkg_descr) -- | Get all the module names from the library (exposed and internal modules) -- which need to be compiled. (This does not include reexports, which -- do not need to be compiled.) libModules :: Library -> [ModuleName] libModules lib = exposedModules lib ++ otherModules (libBuildInfo lib) ++ exposedSignatures lib ++ requiredSignatures lib -- ----------------------------------------------------------------------------- -- Module re-exports data ModuleReexport = ModuleReexport { moduleReexportOriginalPackage :: Maybe PackageName, moduleReexportOriginalName :: ModuleName, moduleReexportName :: ModuleName } deriving (Eq, Generic, Read, Show, Typeable, Data) instance Binary ModuleReexport instance Text ModuleReexport where disp (ModuleReexport mpkgname origname newname) = maybe Disp.empty (\pkgname -> disp pkgname <> Disp.char ':') mpkgname <> disp origname <+> if newname == origname then Disp.empty else Disp.text "as" <+> disp newname parse = do mpkgname <- Parse.option Nothing $ do pkgname <- parse _ <- Parse.char ':' return (Just pkgname) origname <- parse newname <- Parse.option origname $ do Parse.skipSpaces _ <- Parse.string "as" Parse.skipSpaces parse return (ModuleReexport mpkgname origname newname) -- --------------------------------------------------------------------------- -- The Executable type data Executable = Executable { exeName :: String, modulePath :: FilePath, buildInfo :: BuildInfo } deriving (Generic, Show, Read, Eq, Typeable, Data) instance Binary Executable instance Monoid Executable where mempty = Executable { exeName = mempty, modulePath = mempty, buildInfo = mempty } mappend a b = Executable{ exeName = combine' exeName, modulePath = combine modulePath, buildInfo = combine buildInfo } where combine field = field a `mappend` field b combine' field = case (field a, field b) of ("","") -> "" ("", x) -> x (x, "") -> x (x, y) -> error $ "Ambiguous values for executable field: '" ++ x ++ "' and '" ++ y ++ "'" emptyExecutable :: Executable emptyExecutable = mempty -- |does this package have any executables? hasExes :: PackageDescription -> Bool hasExes p = any (buildable . buildInfo) (executables p) -- | Perform the action on each buildable 'Executable' in the package -- description. withExe :: PackageDescription -> (Executable -> IO ()) -> IO () withExe pkg_descr f = sequence_ [f exe | exe <- executables pkg_descr, buildable (buildInfo exe)] -- | Get all the module names from an exe exeModules :: Executable -> [ModuleName] exeModules exe = otherModules (buildInfo exe) -- --------------------------------------------------------------------------- -- The TestSuite type -- | A \"test-suite\" stanza in a cabal file. -- data TestSuite = TestSuite { testName :: String, testInterface :: TestSuiteInterface, testBuildInfo :: BuildInfo, testEnabled :: Bool -- TODO: By having a 'testEnabled' field in the PackageDescription, we -- are mixing build status information (i.e., arguments to 'configure') -- with static package description information. This is undesirable, but -- a better solution is waiting on the next overhaul to the -- GenericPackageDescription -> PackageDescription resolution process. } deriving (Generic, Show, Read, Eq, Typeable, Data) instance Binary TestSuite -- | The test suite interfaces that are currently defined. Each test suite must -- specify which interface it supports. -- -- More interfaces may be defined in future, either new revisions or totally -- new interfaces. -- data TestSuiteInterface = -- | Test interface \"exitcode-stdio-1.0\". The test-suite takes the form -- of an executable. It returns a zero exit code for success, non-zero for -- failure. The stdout and stderr channels may be logged. It takes no -- command line parameters and nothing on stdin. -- TestSuiteExeV10 Version FilePath -- | Test interface \"detailed-0.9\". The test-suite takes the form of a -- library containing a designated module that exports \"tests :: [Test]\". -- | TestSuiteLibV09 Version ModuleName -- | A test suite that does not conform to one of the above interfaces for -- the given reason (e.g. unknown test type). -- | TestSuiteUnsupported TestType deriving (Eq, Generic, Read, Show, Typeable, Data) instance Binary TestSuiteInterface instance Monoid TestSuite where mempty = TestSuite { testName = mempty, testInterface = mempty, testBuildInfo = mempty, testEnabled = False } mappend a b = TestSuite { testName = combine' testName, testInterface = combine testInterface, testBuildInfo = combine testBuildInfo, testEnabled = testEnabled a || testEnabled b } where combine field = field a `mappend` field b combine' f = case (f a, f b) of ("", x) -> x (x, "") -> x (x, y) -> error "Ambiguous values for test field: '" ++ x ++ "' and '" ++ y ++ "'" instance Monoid TestSuiteInterface where mempty = TestSuiteUnsupported (TestTypeUnknown mempty (Version [] [])) mappend a (TestSuiteUnsupported _) = a mappend _ b = b emptyTestSuite :: TestSuite emptyTestSuite = mempty -- | Does this package have any test suites? hasTests :: PackageDescription -> Bool hasTests = any (buildable . testBuildInfo) . testSuites -- | Get all the enabled test suites from a package. enabledTests :: PackageDescription -> [TestSuite] enabledTests = filter testEnabled . testSuites -- | Perform an action on each buildable 'TestSuite' in a package. withTest :: PackageDescription -> (TestSuite -> IO ()) -> IO () withTest pkg_descr f = mapM_ f $ filter (buildable . testBuildInfo) $ enabledTests pkg_descr -- | Get all the module names from a test suite. testModules :: TestSuite -> [ModuleName] testModules test = (case testInterface test of TestSuiteLibV09 _ m -> [m] _ -> []) ++ otherModules (testBuildInfo test) -- | The \"test-type\" field in the test suite stanza. -- data TestType = TestTypeExe Version -- ^ \"type: exitcode-stdio-x.y\" | TestTypeLib Version -- ^ \"type: detailed-x.y\" | TestTypeUnknown String Version -- ^ Some unknown test type e.g. \"type: foo\" deriving (Generic, Show, Read, Eq, Typeable, Data) instance Binary TestType knownTestTypes :: [TestType] knownTestTypes = [ TestTypeExe (Version [1,0] []) , TestTypeLib (Version [0,9] []) ] stdParse :: Text ver => (ver -> String -> res) -> Parse.ReadP r res stdParse f = do cs <- Parse.sepBy1 component (Parse.char '-') _ <- Parse.char '-' ver <- parse let name = intercalate "-" cs return $! f ver (lowercase name) where component = do cs <- Parse.munch1 Char.isAlphaNum if all Char.isDigit cs then Parse.pfail else return cs -- each component must contain an alphabetic character, to avoid -- ambiguity in identifiers like foo-1 (the 1 is the version number). instance Text TestType where disp (TestTypeExe ver) = text "exitcode-stdio-" <> disp ver disp (TestTypeLib ver) = text "detailed-" <> disp ver disp (TestTypeUnknown name ver) = text name <> char '-' <> disp ver parse = stdParse $ \ver name -> case name of "exitcode-stdio" -> TestTypeExe ver "detailed" -> TestTypeLib ver _ -> TestTypeUnknown name ver testType :: TestSuite -> TestType testType test = case testInterface test of TestSuiteExeV10 ver _ -> TestTypeExe ver TestSuiteLibV09 ver _ -> TestTypeLib ver TestSuiteUnsupported testtype -> testtype -- --------------------------------------------------------------------------- -- The Benchmark type -- | A \"benchmark\" stanza in a cabal file. -- data Benchmark = Benchmark { benchmarkName :: String, benchmarkInterface :: BenchmarkInterface, benchmarkBuildInfo :: BuildInfo, benchmarkEnabled :: Bool -- TODO: See TODO for 'testEnabled'. } deriving (Generic, Show, Read, Eq, Typeable, Data) instance Binary Benchmark -- | The benchmark interfaces that are currently defined. Each -- benchmark must specify which interface it supports. -- -- More interfaces may be defined in future, either new revisions or -- totally new interfaces. -- data BenchmarkInterface = -- | Benchmark interface \"exitcode-stdio-1.0\". The benchmark -- takes the form of an executable. It returns a zero exit code -- for success, non-zero for failure. The stdout and stderr -- channels may be logged. It takes no command line parameters -- and nothing on stdin. -- BenchmarkExeV10 Version FilePath -- | A benchmark that does not conform to one of the above -- interfaces for the given reason (e.g. unknown benchmark type). -- | BenchmarkUnsupported BenchmarkType deriving (Eq, Generic, Read, Show, Typeable, Data) instance Binary BenchmarkInterface instance Monoid Benchmark where mempty = Benchmark { benchmarkName = mempty, benchmarkInterface = mempty, benchmarkBuildInfo = mempty, benchmarkEnabled = False } mappend a b = Benchmark { benchmarkName = combine' benchmarkName, benchmarkInterface = combine benchmarkInterface, benchmarkBuildInfo = combine benchmarkBuildInfo, benchmarkEnabled = benchmarkEnabled a || benchmarkEnabled b } where combine field = field a `mappend` field b combine' f = case (f a, f b) of ("", x) -> x (x, "") -> x (x, y) -> error "Ambiguous values for benchmark field: '" ++ x ++ "' and '" ++ y ++ "'" instance Monoid BenchmarkInterface where mempty = BenchmarkUnsupported (BenchmarkTypeUnknown mempty (Version [] [])) mappend a (BenchmarkUnsupported _) = a mappend _ b = b emptyBenchmark :: Benchmark emptyBenchmark = mempty -- | Does this package have any benchmarks? hasBenchmarks :: PackageDescription -> Bool hasBenchmarks = any (buildable . benchmarkBuildInfo) . benchmarks -- | Get all the enabled benchmarks from a package. enabledBenchmarks :: PackageDescription -> [Benchmark] enabledBenchmarks = filter benchmarkEnabled . benchmarks -- | Perform an action on each buildable 'Benchmark' in a package. withBenchmark :: PackageDescription -> (Benchmark -> IO ()) -> IO () withBenchmark pkg_descr f = mapM_ f $ filter (buildable . benchmarkBuildInfo) $ enabledBenchmarks pkg_descr -- | Get all the module names from a benchmark. benchmarkModules :: Benchmark -> [ModuleName] benchmarkModules benchmark = otherModules (benchmarkBuildInfo benchmark) -- | The \"benchmark-type\" field in the benchmark stanza. -- data BenchmarkType = BenchmarkTypeExe Version -- ^ \"type: exitcode-stdio-x.y\" | BenchmarkTypeUnknown String Version -- ^ Some unknown benchmark type e.g. \"type: foo\" deriving (Generic, Show, Read, Eq, Typeable, Data) instance Binary BenchmarkType knownBenchmarkTypes :: [BenchmarkType] knownBenchmarkTypes = [ BenchmarkTypeExe (Version [1,0] []) ] instance Text BenchmarkType where disp (BenchmarkTypeExe ver) = text "exitcode-stdio-" <> disp ver disp (BenchmarkTypeUnknown name ver) = text name <> char '-' <> disp ver parse = stdParse $ \ver name -> case name of "exitcode-stdio" -> BenchmarkTypeExe ver _ -> BenchmarkTypeUnknown name ver benchmarkType :: Benchmark -> BenchmarkType benchmarkType benchmark = case benchmarkInterface benchmark of BenchmarkExeV10 ver _ -> BenchmarkTypeExe ver BenchmarkUnsupported benchmarktype -> benchmarktype -- --------------------------------------------------------------------------- -- The BuildInfo type -- Consider refactoring into executable and library versions. data BuildInfo = BuildInfo { buildable :: Bool, -- ^ component is buildable here buildTools :: [Dependency], -- ^ tools needed to build this bit cppOptions :: [String], -- ^ options for pre-processing Haskell code ccOptions :: [String], -- ^ options for C compiler ldOptions :: [String], -- ^ options for linker pkgconfigDepends :: [Dependency], -- ^ pkg-config packages that are used frameworks :: [String], -- ^support frameworks for Mac OS X cSources :: [FilePath], jsSources :: [FilePath], hsSourceDirs :: [FilePath], -- ^ where to look for the Haskell module hierarchy otherModules :: [ModuleName], -- ^ non-exposed or non-main modules defaultLanguage :: Maybe Language,-- ^ language used when not explicitly specified otherLanguages :: [Language], -- ^ other languages used within the package defaultExtensions :: [Extension], -- ^ language extensions used by all modules otherExtensions :: [Extension], -- ^ other language extensions used within the package oldExtensions :: [Extension], -- ^ the old extensions field, treated same as 'defaultExtensions' extraLibs :: [String], -- ^ what libraries to link with when compiling a program that uses your package extraGHCiLibs :: [String], -- ^ if present, overrides extraLibs when package is loaded with GHCi. extraLibDirs :: [String], includeDirs :: [FilePath], -- ^directories to find .h files includes :: [FilePath], -- ^ The .h files to be found in includeDirs installIncludes :: [FilePath], -- ^ .h files to install with the package options :: [(CompilerFlavor,[String])], profOptions :: [(CompilerFlavor,[String])], sharedOptions :: [(CompilerFlavor,[String])], customFieldsBI :: [(String,String)], -- ^Custom fields starting -- with x-, stored in a -- simple assoc-list. targetBuildDepends :: [Dependency], -- ^ Dependencies specific to a library or executable target targetBuildRenaming :: Map PackageName ModuleRenaming } deriving (Generic, Show, Read, Eq, Typeable, Data) instance Binary BuildInfo instance Monoid BuildInfo where mempty = BuildInfo { buildable = True, buildTools = [], cppOptions = [], ccOptions = [], ldOptions = [], pkgconfigDepends = [], frameworks = [], cSources = [], jsSources = [], hsSourceDirs = [], otherModules = [], defaultLanguage = Nothing, otherLanguages = [], defaultExtensions = [], otherExtensions = [], oldExtensions = [], extraLibs = [], extraGHCiLibs = [], extraLibDirs = [], includeDirs = [], includes = [], installIncludes = [], options = [], profOptions = [], sharedOptions = [], customFieldsBI = [], targetBuildDepends = [], targetBuildRenaming = Map.empty } mappend a b = BuildInfo { buildable = buildable a && buildable b, buildTools = combine buildTools, cppOptions = combine cppOptions, ccOptions = combine ccOptions, ldOptions = combine ldOptions, pkgconfigDepends = combine pkgconfigDepends, frameworks = combineNub frameworks, cSources = combineNub cSources, jsSources = combineNub jsSources, hsSourceDirs = combineNub hsSourceDirs, otherModules = combineNub otherModules, defaultLanguage = combineMby defaultLanguage, otherLanguages = combineNub otherLanguages, defaultExtensions = combineNub defaultExtensions, otherExtensions = combineNub otherExtensions, oldExtensions = combineNub oldExtensions, extraLibs = combine extraLibs, extraGHCiLibs = combine extraGHCiLibs, extraLibDirs = combineNub extraLibDirs, includeDirs = combineNub includeDirs, includes = combineNub includes, installIncludes = combineNub installIncludes, options = combine options, profOptions = combine profOptions, sharedOptions = combine sharedOptions, customFieldsBI = combine customFieldsBI, targetBuildDepends = combineNub targetBuildDepends, targetBuildRenaming = combineMap targetBuildRenaming } where combine field = field a `mappend` field b combineNub field = nub (combine field) combineMby field = field b `mplus` field a combineMap field = Map.unionWith mappend (field a) (field b) emptyBuildInfo :: BuildInfo emptyBuildInfo = mempty -- | The 'BuildInfo' for the library (if there is one and it's buildable), and -- all buildable executables, test suites and benchmarks. Useful for gathering -- dependencies. allBuildInfo :: PackageDescription -> [BuildInfo] allBuildInfo pkg_descr = [ bi | Just lib <- [library pkg_descr] , let bi = libBuildInfo lib , buildable bi ] ++ [ bi | exe <- executables pkg_descr , let bi = buildInfo exe , buildable bi ] ++ [ bi | tst <- testSuites pkg_descr , let bi = testBuildInfo tst , buildable bi , testEnabled tst ] ++ [ bi | tst <- benchmarks pkg_descr , let bi = benchmarkBuildInfo tst , buildable bi , benchmarkEnabled tst ] --FIXME: many of the places where this is used, we actually want to look at -- unbuildable bits too, probably need separate functions -- | The 'Language's used by this component -- allLanguages :: BuildInfo -> [Language] allLanguages bi = maybeToList (defaultLanguage bi) ++ otherLanguages bi -- | The 'Extension's that are used somewhere by this component -- allExtensions :: BuildInfo -> [Extension] allExtensions bi = usedExtensions bi ++ otherExtensions bi -- | The 'Extensions' that are used by all modules in this component -- usedExtensions :: BuildInfo -> [Extension] usedExtensions bi = oldExtensions bi ++ defaultExtensions bi type HookedBuildInfo = (Maybe BuildInfo, [(String, BuildInfo)]) emptyHookedBuildInfo :: HookedBuildInfo emptyHookedBuildInfo = (Nothing, []) -- |Select options for a particular Haskell compiler. hcOptions :: CompilerFlavor -> BuildInfo -> [String] hcOptions = lookupHcOptions options hcProfOptions :: CompilerFlavor -> BuildInfo -> [String] hcProfOptions = lookupHcOptions profOptions hcSharedOptions :: CompilerFlavor -> BuildInfo -> [String] hcSharedOptions = lookupHcOptions sharedOptions lookupHcOptions :: (BuildInfo -> [(CompilerFlavor,[String])]) -> CompilerFlavor -> BuildInfo -> [String] lookupHcOptions f hc bi = [ opt | (hc',opts) <- f bi , hc' == hc , opt <- opts ] -- ------------------------------------------------------------ -- * Source repos -- ------------------------------------------------------------ -- | Information about the source revision control system for a package. -- -- When specifying a repo it is useful to know the meaning or intention of the -- information as doing so enables automation. There are two obvious common -- purposes: one is to find the repo for the latest development version, the -- other is to find the repo for this specific release. The 'ReopKind' -- specifies which one we mean (or another custom one). -- -- A package can specify one or the other kind or both. Most will specify just -- a head repo but some may want to specify a repo to reconstruct the sources -- for this package release. -- -- The required information is the 'RepoType' which tells us if it's using -- 'Darcs', 'Git' for example. The 'repoLocation' and other details are -- interpreted according to the repo type. -- data SourceRepo = SourceRepo { -- | The kind of repo. This field is required. repoKind :: RepoKind, -- | The type of the source repository system for this repo, eg 'Darcs' or -- 'Git'. This field is required. repoType :: Maybe RepoType, -- | The location of the repository. For most 'RepoType's this is a URL. -- This field is required. repoLocation :: Maybe String, -- | 'CVS' can put multiple \"modules\" on one server and requires a -- module name in addition to the location to identify a particular repo. -- Logically this is part of the location but unfortunately has to be -- specified separately. This field is required for the 'CVS' 'RepoType' and -- should not be given otherwise. repoModule :: Maybe String, -- | The name or identifier of the branch, if any. Many source control -- systems have the notion of multiple branches in a repo that exist in the -- same location. For example 'Git' and 'CVS' use this while systems like -- 'Darcs' use different locations for different branches. This field is -- optional but should be used if necessary to identify the sources, -- especially for the 'RepoThis' repo kind. repoBranch :: Maybe String, -- | The tag identify a particular state of the repository. This should be -- given for the 'RepoThis' repo kind and not for 'RepoHead' kind. -- repoTag :: Maybe String, -- | Some repositories contain multiple projects in different subdirectories -- This field specifies the subdirectory where this packages sources can be -- found, eg the subdirectory containing the @.cabal@ file. It is interpreted -- relative to the root of the repository. This field is optional. If not -- given the default is \".\" ie no subdirectory. repoSubdir :: Maybe FilePath } deriving (Eq, Generic, Read, Show, Typeable, Data) instance Binary SourceRepo -- | What this repo info is for, what it represents. -- data RepoKind = -- | The repository for the \"head\" or development version of the project. -- This repo is where we should track the latest development activity or -- the usual repo people should get to contribute patches. RepoHead -- | The repository containing the sources for this exact package version -- or release. For this kind of repo a tag should be given to give enough -- information to re-create the exact sources. | RepoThis | RepoKindUnknown String deriving (Eq, Generic, Ord, Read, Show, Typeable, Data) instance Binary RepoKind -- | An enumeration of common source control systems. The fields used in the -- 'SourceRepo' depend on the type of repo. The tools and methods used to -- obtain and track the repo depend on the repo type. -- data RepoType = Darcs | Git | SVN | CVS | Mercurial | GnuArch | Bazaar | Monotone | OtherRepoType String deriving (Eq, Generic, Ord, Read, Show, Typeable, Data) instance Binary RepoType knownRepoTypes :: [RepoType] knownRepoTypes = [Darcs, Git, SVN, CVS ,Mercurial, GnuArch, Bazaar, Monotone] repoTypeAliases :: RepoType -> [String] repoTypeAliases Bazaar = ["bzr"] repoTypeAliases Mercurial = ["hg"] repoTypeAliases GnuArch = ["arch"] repoTypeAliases _ = [] instance Text RepoKind where disp RepoHead = Disp.text "head" disp RepoThis = Disp.text "this" disp (RepoKindUnknown other) = Disp.text other parse = do name <- ident return $ case lowercase name of "head" -> RepoHead "this" -> RepoThis _ -> RepoKindUnknown name instance Text RepoType where disp (OtherRepoType other) = Disp.text other disp other = Disp.text (lowercase (show other)) parse = fmap classifyRepoType ident classifyRepoType :: String -> RepoType classifyRepoType s = fromMaybe (OtherRepoType s) $ lookup (lowercase s) repoTypeMap where repoTypeMap = [ (name, repoType') | repoType' <- knownRepoTypes , name <- display repoType' : repoTypeAliases repoType' ] ident :: Parse.ReadP r String ident = Parse.munch1 (\c -> Char.isAlphaNum c || c == '_' || c == '-') lowercase :: String -> String lowercase = map Char.toLower -- ------------------------------------------------------------ -- * Utils -- ------------------------------------------------------------ updatePackageDescription :: HookedBuildInfo -> PackageDescription -> PackageDescription updatePackageDescription (mb_lib_bi, exe_bi) p = p{ executables = updateExecutables exe_bi (executables p) , library = updateLibrary mb_lib_bi (library p) } where updateLibrary :: Maybe BuildInfo -> Maybe Library -> Maybe Library updateLibrary (Just bi) (Just lib) = Just (lib{libBuildInfo = bi `mappend` libBuildInfo lib}) updateLibrary Nothing mb_lib = mb_lib updateLibrary (Just _) Nothing = Nothing updateExecutables :: [(String, BuildInfo)] -- ^[(exeName, new buildinfo)] -> [Executable] -- ^list of executables to update -> [Executable] -- ^list with exeNames updated updateExecutables exe_bi' executables' = foldr updateExecutable executables' exe_bi' updateExecutable :: (String, BuildInfo) -- ^(exeName, new buildinfo) -> [Executable] -- ^list of executables to update -> [Executable] -- ^list with exeName updated updateExecutable _ [] = [] updateExecutable exe_bi'@(name,bi) (exe:exes) | exeName exe == name = exe{buildInfo = bi `mappend` buildInfo exe} : exes | otherwise = exe : updateExecutable exe_bi' exes -- --------------------------------------------------------------------------- -- The GenericPackageDescription type data GenericPackageDescription = GenericPackageDescription { packageDescription :: PackageDescription, genPackageFlags :: [Flag], condLibrary :: Maybe (CondTree ConfVar [Dependency] Library), condExecutables :: [(String, CondTree ConfVar [Dependency] Executable)], condTestSuites :: [(String, CondTree ConfVar [Dependency] TestSuite)], condBenchmarks :: [(String, CondTree ConfVar [Dependency] Benchmark)] } deriving (Show, Eq, Typeable, Data) instance Package GenericPackageDescription where packageId = packageId . packageDescription --TODO: make PackageDescription an instance of Text. -- | A flag can represent a feature to be included, or a way of linking -- a target against its dependencies, or in fact whatever you can think of. data Flag = MkFlag { flagName :: FlagName , flagDescription :: String , flagDefault :: Bool , flagManual :: Bool } deriving (Show, Eq, Typeable, Data) -- | A 'FlagName' is the name of a user-defined configuration flag newtype FlagName = FlagName String deriving (Eq, Generic, Ord, Show, Read, Typeable, Data) instance Binary FlagName -- | A 'FlagAssignment' is a total or partial mapping of 'FlagName's to -- 'Bool' flag values. It represents the flags chosen by the user or -- discovered during configuration. For example @--flags=foo --flags=-bar@ -- becomes @[("foo", True), ("bar", False)]@ -- type FlagAssignment = [(FlagName, Bool)] -- | A @ConfVar@ represents the variable type used. data ConfVar = OS OS | Arch Arch | Flag FlagName | Impl CompilerFlavor VersionRange deriving (Eq, Show, Typeable, Data) -- | A boolean expression parameterized over the variable type used. data Condition c = Var c | Lit Bool | CNot (Condition c) | COr (Condition c) (Condition c) | CAnd (Condition c) (Condition c) deriving (Show, Eq, Typeable, Data) data CondTree v c a = CondNode { condTreeData :: a , condTreeConstraints :: c , condTreeComponents :: [( Condition v , CondTree v c a , Maybe (CondTree v c a))] } deriving (Show, Eq, Typeable, Data) Cabal-1.22.5.0/Distribution/ParseUtils.hs0000644000000000000000000007212612627136220016246 0ustar0000000000000000{-# LANGUAGE CPP #-} ----------------------------------------------------------------------------- -- | -- Module : Distribution.ParseUtils -- Copyright : (c) The University of Glasgow 2004 -- License : BSD3 -- -- Maintainer : cabal-devel@haskell.org -- Portability : portable -- -- Utilities for parsing 'PackageDescription' and 'InstalledPackageInfo'. -- -- The @.cabal@ file format is not trivial, especially with the introduction -- of configurations and the section syntax that goes with that. This module -- has a bunch of parsing functions that is used by the @.cabal@ parser and a -- couple others. It has the parsing framework code and also little parsers for -- many of the formats we get in various @.cabal@ file fields, like module -- names, comma separated lists etc. -- This module is meant to be local-only to Distribution... {-# OPTIONS_HADDOCK hide #-} module Distribution.ParseUtils ( LineNo, PError(..), PWarning(..), locatedErrorMsg, syntaxError, warning, runP, runE, ParseResult(..), catchParseError, parseFail, showPWarning, Field(..), fName, lineNo, FieldDescr(..), ppField, ppFields, readFields, readFieldsFlat, showFields, showSingleNamedField, showSimpleSingleNamedField, parseFields, parseFieldsFlat, parseFilePathQ, parseTokenQ, parseTokenQ', parseModuleNameQ, parseBuildTool, parsePkgconfigDependency, parseOptVersion, parsePackageNameQ, parseVersionRangeQ, parseTestedWithQ, parseLicenseQ, parseLanguageQ, parseExtensionQ, parseSepList, parseCommaList, parseOptCommaList, showFilePath, showToken, showTestedWith, showFreeText, parseFreeText, field, simpleField, listField, listFieldWithSep, spaceListField, commaListField, commaListFieldWithSep, commaNewLineListField, optsField, liftField, boolField, parseQuoted, indentWith, UnrecFieldParser, warnUnrec, ignoreUnrec, ) where import Distribution.Compiler (CompilerFlavor, parseCompilerFlavorCompat) import Distribution.License import Distribution.Version ( Version(..), VersionRange, anyVersion ) import Distribution.Package ( PackageName(..), Dependency(..) ) import Distribution.ModuleName (ModuleName) import Distribution.Compat.ReadP as ReadP hiding (get) import Distribution.ReadE import Distribution.Text ( Text(..) ) import Distribution.Simple.Utils ( comparing, dropWhileEndLE, intercalate, lowercase , normaliseLineEndings ) import Language.Haskell.Extension ( Language, Extension ) import Text.PrettyPrint hiding (braces) import Data.Char (isSpace, toLower, isAlphaNum, isDigit) import Data.Maybe (fromMaybe) import Data.Tree as Tree (Tree(..), flatten) import qualified Data.Map as Map import Control.Monad (foldM, ap) #if __GLASGOW_HASKELL__ < 710 import Control.Applicative (Applicative(..)) #endif import System.FilePath (normalise) import Data.List (sortBy) -- ----------------------------------------------------------------------------- type LineNo = Int type Separator = ([Doc] -> Doc) data PError = AmbiguousParse String LineNo | NoParse String LineNo | TabsError LineNo | FromString String (Maybe LineNo) deriving (Eq, Show) data PWarning = PWarning String | UTFWarning LineNo String deriving (Eq, Show) showPWarning :: FilePath -> PWarning -> String showPWarning fpath (PWarning msg) = normalise fpath ++ ": " ++ msg showPWarning fpath (UTFWarning line fname) = normalise fpath ++ ":" ++ show line ++ ": Invalid UTF-8 text in the '" ++ fname ++ "' field." data ParseResult a = ParseFailed PError | ParseOk [PWarning] a deriving Show instance Functor ParseResult where fmap _ (ParseFailed err) = ParseFailed err fmap f (ParseOk ws x) = ParseOk ws $ f x instance Applicative ParseResult where pure = return (<*>) = ap instance Monad ParseResult where return = ParseOk [] ParseFailed err >>= _ = ParseFailed err ParseOk ws x >>= f = case f x of ParseFailed err -> ParseFailed err ParseOk ws' x' -> ParseOk (ws'++ws) x' fail s = ParseFailed (FromString s Nothing) catchParseError :: ParseResult a -> (PError -> ParseResult a) -> ParseResult a p@(ParseOk _ _) `catchParseError` _ = p ParseFailed e `catchParseError` k = k e parseFail :: PError -> ParseResult a parseFail = ParseFailed runP :: LineNo -> String -> ReadP a a -> String -> ParseResult a runP line fieldname p s = case [ x | (x,"") <- results ] of [a] -> ParseOk (utf8Warnings line fieldname s) a --TODO: what is this double parse thing all about? -- Can't we just do the all isSpace test the first time? [] -> case [ x | (x,ys) <- results, all isSpace ys ] of [a] -> ParseOk (utf8Warnings line fieldname s) a [] -> ParseFailed (NoParse fieldname line) _ -> ParseFailed (AmbiguousParse fieldname line) _ -> ParseFailed (AmbiguousParse fieldname line) where results = readP_to_S p s runE :: LineNo -> String -> ReadE a -> String -> ParseResult a runE line fieldname p s = case runReadE p s of Right a -> ParseOk (utf8Warnings line fieldname s) a Left e -> syntaxError line $ "Parse of field '" ++ fieldname ++ "' failed (" ++ e ++ "): " ++ s utf8Warnings :: LineNo -> String -> String -> [PWarning] utf8Warnings line fieldname s = take 1 [ UTFWarning n fieldname | (n,l) <- zip [line..] (lines s) , '\xfffd' `elem` l ] locatedErrorMsg :: PError -> (Maybe LineNo, String) locatedErrorMsg (AmbiguousParse f n) = (Just n, "Ambiguous parse in field '"++f++"'.") locatedErrorMsg (NoParse f n) = (Just n, "Parse of field '"++f++"' failed.") locatedErrorMsg (TabsError n) = (Just n, "Tab used as indentation.") locatedErrorMsg (FromString s n) = (n, s) syntaxError :: LineNo -> String -> ParseResult a syntaxError n s = ParseFailed $ FromString s (Just n) tabsError :: LineNo -> ParseResult a tabsError ln = ParseFailed $ TabsError ln warning :: String -> ParseResult () warning s = ParseOk [PWarning s] () -- | Field descriptor. The parameter @a@ parameterizes over where the field's -- value is stored in. data FieldDescr a = FieldDescr { fieldName :: String , fieldGet :: a -> Doc , fieldSet :: LineNo -> String -> a -> ParseResult a -- ^ @fieldSet n str x@ Parses the field value from the given input -- string @str@ and stores the result in @x@ if the parse was -- successful. Otherwise, reports an error on line number @n@. } field :: String -> (a -> Doc) -> ReadP a a -> FieldDescr a field name showF readF = FieldDescr name showF (\line val _st -> runP line name readF val) -- Lift a field descriptor storing into an 'a' to a field descriptor storing -- into a 'b'. liftField :: (b -> a) -> (a -> b -> b) -> FieldDescr a -> FieldDescr b liftField get set (FieldDescr name showF parseF) = FieldDescr name (showF . get) (\line str b -> do a <- parseF line str (get b) return (set a b)) -- Parser combinator for simple fields. Takes a field name, a pretty printer, -- a parser function, an accessor, and a setter, returns a FieldDescr over the -- compoid structure. simpleField :: String -> (a -> Doc) -> ReadP a a -> (b -> a) -> (a -> b -> b) -> FieldDescr b simpleField name showF readF get set = liftField get set $ field name showF readF commaListFieldWithSep :: Separator -> String -> (a -> Doc) -> ReadP [a] a -> (b -> [a]) -> ([a] -> b -> b) -> FieldDescr b commaListFieldWithSep separator name showF readF get set = liftField get set' $ field name showF' (parseCommaList readF) where set' xs b = set (get b ++ xs) b showF' = separator . punctuate comma . map showF commaListField :: String -> (a -> Doc) -> ReadP [a] a -> (b -> [a]) -> ([a] -> b -> b) -> FieldDescr b commaListField = commaListFieldWithSep fsep commaNewLineListField :: String -> (a -> Doc) -> ReadP [a] a -> (b -> [a]) -> ([a] -> b -> b) -> FieldDescr b commaNewLineListField = commaListFieldWithSep sep spaceListField :: String -> (a -> Doc) -> ReadP [a] a -> (b -> [a]) -> ([a] -> b -> b) -> FieldDescr b spaceListField name showF readF get set = liftField get set' $ field name showF' (parseSpaceList readF) where set' xs b = set (get b ++ xs) b showF' = fsep . map showF listFieldWithSep :: Separator -> String -> (a -> Doc) -> ReadP [a] a -> (b -> [a]) -> ([a] -> b -> b) -> FieldDescr b listFieldWithSep separator name showF readF get set = liftField get set' $ field name showF' (parseOptCommaList readF) where set' xs b = set (get b ++ xs) b showF' = separator . map showF listField :: String -> (a -> Doc) -> ReadP [a] a -> (b -> [a]) -> ([a] -> b -> b) -> FieldDescr b listField = listFieldWithSep fsep optsField :: String -> CompilerFlavor -> (b -> [(CompilerFlavor,[String])]) -> ([(CompilerFlavor,[String])] -> b -> b) -> FieldDescr b optsField name flavor get set = liftField (fromMaybe [] . lookup flavor . get) (\opts b -> set (reorder (update flavor opts (get b))) b) $ field name showF (sepBy parseTokenQ' (munch1 isSpace)) where update _ opts l | all null opts = l --empty opts as if no opts update f opts [] = [(f,opts)] update f opts ((f',opts'):rest) | f == f' = (f, opts' ++ opts) : rest | otherwise = (f',opts') : update f opts rest reorder = sortBy (comparing fst) showF = hsep . map text -- TODO: this is a bit smelly hack. It's because we want to parse bool fields -- liberally but not accept new parses. We cannot do that with ReadP -- because it does not support warnings. We need a new parser framework! boolField :: String -> (b -> Bool) -> (Bool -> b -> b) -> FieldDescr b boolField name get set = liftField get set (FieldDescr name showF readF) where showF = text . show readF line str _ | str == "True" = ParseOk [] True | str == "False" = ParseOk [] False | lstr == "true" = ParseOk [caseWarning] True | lstr == "false" = ParseOk [caseWarning] False | otherwise = ParseFailed (NoParse name line) where lstr = lowercase str caseWarning = PWarning $ "The '" ++ name ++ "' field is case sensitive, use 'True' or 'False'." ppFields :: [FieldDescr a] -> a -> Doc ppFields fields x = vcat [ ppField name (getter x) | FieldDescr name getter _ <- fields ] ppField :: String -> Doc -> Doc ppField name fielddoc | isEmpty fielddoc = empty | name `elem` nestedFields = text name <> colon $+$ nest indentWith fielddoc | otherwise = text name <> colon <+> fielddoc where nestedFields = [ "description" , "build-depends" , "data-files" , "extra-source-files" , "extra-tmp-files" , "exposed-modules" , "c-sources" , "js-sources" , "extra-libraries" , "includes" , "install-includes" , "other-modules" , "depends" ] showFields :: [FieldDescr a] -> a -> String showFields fields = render . ($+$ text "") . ppFields fields showSingleNamedField :: [FieldDescr a] -> String -> Maybe (a -> String) showSingleNamedField fields f = case [ get | (FieldDescr f' get _) <- fields, f' == f ] of [] -> Nothing (get:_) -> Just (render . ppField f . get) showSimpleSingleNamedField :: [FieldDescr a] -> String -> Maybe (a -> String) showSimpleSingleNamedField fields f = case [ get | (FieldDescr f' get _) <- fields, f' == f ] of [] -> Nothing (get:_) -> Just (renderStyle myStyle . get) where myStyle = style { mode = LeftMode } parseFields :: [FieldDescr a] -> a -> String -> ParseResult a parseFields fields initial str = readFields str >>= accumFields fields initial parseFieldsFlat :: [FieldDescr a] -> a -> String -> ParseResult a parseFieldsFlat fields initial str = readFieldsFlat str >>= accumFields fields initial accumFields :: [FieldDescr a] -> a -> [Field] -> ParseResult a accumFields fields = foldM setField where fieldMap = Map.fromList [ (name, f) | f@(FieldDescr name _ _) <- fields ] setField accum (F line name value) = case Map.lookup name fieldMap of Just (FieldDescr _ _ set) -> set line value accum Nothing -> do warning ("Unrecognized field " ++ name ++ " on line " ++ show line) return accum setField accum f = do warning ("Unrecognized stanza on line " ++ show (lineNo f)) return accum -- | The type of a function which, given a name-value pair of an -- unrecognized field, and the current structure being built, -- decides whether to incorporate the unrecognized field -- (by returning Just x, where x is a possibly modified version -- of the structure being built), or not (by returning Nothing). type UnrecFieldParser a = (String,String) -> a -> Maybe a -- | A default unrecognized field parser which simply returns Nothing, -- i.e. ignores all unrecognized fields, so warnings will be generated. warnUnrec :: UnrecFieldParser a warnUnrec _ _ = Nothing -- | A default unrecognized field parser which silently (i.e. no -- warnings will be generated) ignores unrecognized fields, by -- returning the structure being built unmodified. ignoreUnrec :: UnrecFieldParser a ignoreUnrec _ = Just ------------------------------------------------------------------------------ -- The data type for our three syntactic categories data Field = F LineNo String String -- ^ A regular @: @ field | Section LineNo String String [Field] -- ^ A section with a name and possible parameter. The syntactic -- structure is: -- -- @ -- { -- * -- } -- @ | IfBlock LineNo String [Field] [Field] -- ^ A conditional block with an optional else branch: -- -- @ -- if { -- * -- } else { -- * -- } -- @ deriving (Show ,Eq) -- for testing lineNo :: Field -> LineNo lineNo (F n _ _) = n lineNo (Section n _ _ _) = n lineNo (IfBlock n _ _ _) = n fName :: Field -> String fName (F _ n _) = n fName (Section _ n _ _) = n fName _ = error "fname: not a field or section" readFields :: String -> ParseResult [Field] readFields input = ifelse =<< mapM (mkField 0) =<< mkTree tokens where ls = (lines . normaliseLineEndings) input tokens = (concatMap tokeniseLine . trimLines) ls readFieldsFlat :: String -> ParseResult [Field] readFieldsFlat input = mapM (mkField 0) =<< mkTree tokens where ls = (lines . normaliseLineEndings) input tokens = (concatMap tokeniseLineFlat . trimLines) ls -- attach line number and determine indentation trimLines :: [String] -> [(LineNo, Indent, HasTabs, String)] trimLines ls = [ (lineno, indent, hastabs, trimTrailing l') | (lineno, l) <- zip [1..] ls , let (sps, l') = span isSpace l indent = length sps hastabs = '\t' `elem` sps , validLine l' ] where validLine ('-':'-':_) = False -- Comment validLine [] = False -- blank line validLine _ = True -- | We parse generically based on indent level and braces '{' '}'. To do that -- we split into lines and then '{' '}' tokens and other spans within a line. data Token = -- | The 'Line' token is for bits that /start/ a line, eg: -- -- > "\n blah blah { blah" -- -- tokenises to: -- -- > [Line n 2 False "blah blah", OpenBracket, Span n "blah"] -- -- so lines are the only ones that can have nested layout, since they -- have a known indentation level. -- -- eg: we can't have this: -- -- > if ... { -- > } else -- > other -- -- because other cannot nest under else, since else doesn't start a line -- so cannot have nested layout. It'd have to be: -- -- > if ... { -- > } -- > else -- > other -- -- but that's not so common, people would normally use layout or -- brackets not both in a single @if else@ construct. -- -- > if ... { foo : bar } -- > else -- > other -- -- this is OK Line LineNo Indent HasTabs String | Span LineNo String -- ^ span in a line, following brackets | OpenBracket LineNo | CloseBracket LineNo type Indent = Int type HasTabs = Bool -- | Tokenise a single line, splitting on '{' '}' and the spans in between. -- Also trims leading & trailing space on those spans within the line. tokeniseLine :: (LineNo, Indent, HasTabs, String) -> [Token] tokeniseLine (n0, i, t, l) = case split n0 l of (Span _ l':ss) -> Line n0 i t l' :ss cs -> cs where split _ "" = [] split n s = case span (\c -> c /='}' && c /= '{') s of ("", '{' : s') -> OpenBracket n : split n s' (w , '{' : s') -> mkspan n w (OpenBracket n : split n s') ("", '}' : s') -> CloseBracket n : split n s' (w , '}' : s') -> mkspan n w (CloseBracket n : split n s') (w , _) -> mkspan n w [] mkspan n s ss | null s' = ss | otherwise = Span n s' : ss where s' = trimTrailing (trimLeading s) tokeniseLineFlat :: (LineNo, Indent, HasTabs, String) -> [Token] tokeniseLineFlat (n0, i, t, l) | null l' = [] | otherwise = [Line n0 i t l'] where l' = trimTrailing (trimLeading l) trimLeading, trimTrailing :: String -> String trimLeading = dropWhile isSpace trimTrailing = dropWhileEndLE isSpace type SyntaxTree = Tree (LineNo, HasTabs, String) -- | Parse the stream of tokens into a tree of them, based on indent \/ layout mkTree :: [Token] -> ParseResult [SyntaxTree] mkTree toks = layout 0 [] toks >>= \(trees, trailing) -> case trailing of [] -> return trees OpenBracket n:_ -> syntaxError n "mismatched brackets, unexpected {" CloseBracket n:_ -> syntaxError n "mismatched brackets, unexpected }" -- the following two should never happen: Span n l :_ -> syntaxError n $ "unexpected span: " ++ show l Line n _ _ l :_ -> syntaxError n $ "unexpected line: " ++ show l -- | Parse the stream of tokens into a tree of them, based on indent -- This parse state expect to be in a layout context, though possibly -- nested within a braces context so we may still encounter closing braces. layout :: Indent -- ^ indent level of the parent\/previous line -> [SyntaxTree] -- ^ accumulating param, trees in this level -> [Token] -- ^ remaining tokens -> ParseResult ([SyntaxTree], [Token]) -- ^ collected trees on this level and trailing tokens layout _ a [] = return (reverse a, []) layout i a (s@(Line _ i' _ _):ss) | i' < i = return (reverse a, s:ss) layout i a (Line n _ t l:OpenBracket n':ss) = do (sub, ss') <- braces n' [] ss layout i (Node (n,t,l) sub:a) ss' layout i a (Span n l:OpenBracket n':ss) = do (sub, ss') <- braces n' [] ss layout i (Node (n,False,l) sub:a) ss' -- look ahead to see if following lines are more indented, giving a sub-tree layout i a (Line n i' t l:ss) = do lookahead <- layout (i'+1) [] ss case lookahead of ([], _) -> layout i (Node (n,t,l) [] :a) ss (ts, ss') -> layout i (Node (n,t,l) ts :a) ss' layout _ _ ( OpenBracket n :_) = syntaxError n "unexpected '{'" layout _ a (s@(CloseBracket _):ss) = return (reverse a, s:ss) layout _ _ ( Span n l : _) = syntaxError n $ "unexpected span: " ++ show l -- | Parse the stream of tokens into a tree of them, based on explicit braces -- This parse state expects to find a closing bracket. braces :: LineNo -- ^ line of the '{', used for error messages -> [SyntaxTree] -- ^ accumulating param, trees in this level -> [Token] -- ^ remaining tokens -> ParseResult ([SyntaxTree],[Token]) -- ^ collected trees on this level and trailing tokens braces m a (Line n _ t l:OpenBracket n':ss) = do (sub, ss') <- braces n' [] ss braces m (Node (n,t,l) sub:a) ss' braces m a (Span n l:OpenBracket n':ss) = do (sub, ss') <- braces n' [] ss braces m (Node (n,False,l) sub:a) ss' braces m a (Line n i t l:ss) = do lookahead <- layout (i+1) [] ss case lookahead of ([], _) -> braces m (Node (n,t,l) [] :a) ss (ts, ss') -> braces m (Node (n,t,l) ts :a) ss' braces m a (Span n l:ss) = braces m (Node (n,False,l) []:a) ss braces _ a (CloseBracket _:ss) = return (reverse a, ss) braces n _ [] = syntaxError n $ "opening brace '{'" ++ "has no matching closing brace '}'" braces _ _ (OpenBracket n:_) = syntaxError n "unexpected '{'" -- | Convert the parse tree into the Field AST -- Also check for dodgy uses of tabs in indentation. mkField :: Int -> SyntaxTree -> ParseResult Field mkField d (Node (n,t,_) _) | d >= 1 && t = tabsError n mkField d (Node (n,_,l) ts) = case span (\c -> isAlphaNum c || c == '-') l of ([], _) -> syntaxError n $ "unrecognised field or section: " ++ show l (name, rest) -> case trimLeading rest of (':':rest') -> do let followingLines = concatMap Tree.flatten ts tabs = not (null [()| (_,True,_) <- followingLines ]) if tabs && d >= 1 then tabsError n else return $ F n (map toLower name) (fieldValue rest' followingLines) rest' -> do ts' <- mapM (mkField (d+1)) ts return (Section n (map toLower name) rest' ts') where fieldValue firstLine followingLines = let firstLine' = trimLeading firstLine followingLines' = map (\(_,_,s) -> stripDot s) followingLines allLines | null firstLine' = followingLines' | otherwise = firstLine' : followingLines' in intercalate "\n" allLines stripDot "." = "" stripDot s = s -- | Convert if/then/else 'Section's to 'IfBlock's ifelse :: [Field] -> ParseResult [Field] ifelse [] = return [] ifelse (Section n "if" cond thenpart :Section _ "else" as elsepart:fs) | null cond = syntaxError n "'if' with missing condition" | null thenpart = syntaxError n "'then' branch of 'if' is empty" | not (null as) = syntaxError n "'else' takes no arguments" | null elsepart = syntaxError n "'else' branch of 'if' is empty" | otherwise = do tp <- ifelse thenpart ep <- ifelse elsepart fs' <- ifelse fs return (IfBlock n cond tp ep:fs') ifelse (Section n "if" cond thenpart:fs) | null cond = syntaxError n "'if' with missing condition" | null thenpart = syntaxError n "'then' branch of 'if' is empty" | otherwise = do tp <- ifelse thenpart fs' <- ifelse fs return (IfBlock n cond tp []:fs') ifelse (Section n "else" _ _:_) = syntaxError n "stray 'else' with no preceding 'if'" ifelse (Section n s a fs':fs) = do fs'' <- ifelse fs' fs''' <- ifelse fs return (Section n s a fs'' : fs''') ifelse (f:fs) = do fs' <- ifelse fs return (f : fs') ------------------------------------------------------------------------------ -- |parse a module name parseModuleNameQ :: ReadP r ModuleName parseModuleNameQ = parseQuoted parse <++ parse parseFilePathQ :: ReadP r FilePath parseFilePathQ = parseTokenQ -- removed until normalise is no longer broken, was: -- liftM normalise parseTokenQ betweenSpaces :: ReadP r a -> ReadP r a betweenSpaces act = do skipSpaces res <- act skipSpaces return res parseBuildTool :: ReadP r Dependency parseBuildTool = do name <- parseBuildToolNameQ ver <- betweenSpaces $ parseVersionRangeQ <++ return anyVersion return $ Dependency name ver parseBuildToolNameQ :: ReadP r PackageName parseBuildToolNameQ = parseQuoted parseBuildToolName <++ parseBuildToolName -- like parsePackageName but accepts symbols in components parseBuildToolName :: ReadP r PackageName parseBuildToolName = do ns <- sepBy1 component (ReadP.char '-') return (PackageName (intercalate "-" ns)) where component = do cs <- munch1 (\c -> isAlphaNum c || c == '+' || c == '_') if all isDigit cs then pfail else return cs -- pkg-config allows versions and other letters in package names, -- eg "gtk+-2.0" is a valid pkg-config package _name_. -- It then has a package version number like 2.10.13 parsePkgconfigDependency :: ReadP r Dependency parsePkgconfigDependency = do name <- munch1 (\c -> isAlphaNum c || c `elem` "+-._") ver <- betweenSpaces $ parseVersionRangeQ <++ return anyVersion return $ Dependency (PackageName name) ver parsePackageNameQ :: ReadP r PackageName parsePackageNameQ = parseQuoted parse <++ parse parseVersionRangeQ :: ReadP r VersionRange parseVersionRangeQ = parseQuoted parse <++ parse parseOptVersion :: ReadP r Version parseOptVersion = parseQuoted ver <++ ver where ver :: ReadP r Version ver = parse <++ return noVersion noVersion = Version [] [] parseTestedWithQ :: ReadP r (CompilerFlavor,VersionRange) parseTestedWithQ = parseQuoted tw <++ tw where tw :: ReadP r (CompilerFlavor,VersionRange) tw = do compiler <- parseCompilerFlavorCompat version <- betweenSpaces $ parse <++ return anyVersion return (compiler,version) parseLicenseQ :: ReadP r License parseLicenseQ = parseQuoted parse <++ parse -- urgh, we can't define optQuotes :: ReadP r a -> ReadP r a -- because the "compat" version of ReadP isn't quite powerful enough. In -- particular, the type of <++ is ReadP r r -> ReadP r a -> ReadP r a -- Hence the trick above to make 'lic' polymorphic. parseLanguageQ :: ReadP r Language parseLanguageQ = parseQuoted parse <++ parse parseExtensionQ :: ReadP r Extension parseExtensionQ = parseQuoted parse <++ parse parseHaskellString :: ReadP r String parseHaskellString = readS_to_P reads parseTokenQ :: ReadP r String parseTokenQ = parseHaskellString <++ munch1 (\x -> not (isSpace x) && x /= ',') parseTokenQ' :: ReadP r String parseTokenQ' = parseHaskellString <++ munch1 (not . isSpace) parseSepList :: ReadP r b -> ReadP r a -- ^The parser for the stuff between commas -> ReadP r [a] parseSepList sepr p = sepBy p separator where separator = betweenSpaces sepr parseSpaceList :: ReadP r a -- ^The parser for the stuff between commas -> ReadP r [a] parseSpaceList p = sepBy p skipSpaces parseCommaList :: ReadP r a -- ^The parser for the stuff between commas -> ReadP r [a] parseCommaList = parseSepList (ReadP.char ',') parseOptCommaList :: ReadP r a -- ^The parser for the stuff between commas -> ReadP r [a] parseOptCommaList = parseSepList (optional (ReadP.char ',')) parseQuoted :: ReadP r a -> ReadP r a parseQuoted = between (ReadP.char '"') (ReadP.char '"') parseFreeText :: ReadP.ReadP s String parseFreeText = ReadP.munch (const True) -- -------------------------------------------- -- ** Pretty printing showFilePath :: FilePath -> Doc showFilePath "" = empty showFilePath x = showToken x showToken :: String -> Doc showToken str | not (any dodgy str) && not (null str) = text str | otherwise = text (show str) where dodgy c = isSpace c || c == ',' showTestedWith :: (CompilerFlavor,VersionRange) -> Doc showTestedWith (compiler, version) = text (show compiler) <+> disp version -- | Pretty-print free-format text, ensuring that it is vertically aligned, -- and with blank lines replaced by dots for correct re-parsing. showFreeText :: String -> Doc showFreeText "" = empty showFreeText s = vcat [text (if null l then "." else l) | l <- lines_ s] -- | 'lines_' breaks a string up into a list of strings at newline -- characters. The resulting strings do not contain newlines. lines_ :: String -> [String] lines_ [] = [""] lines_ s = let (l, s') = break (== '\n') s in l : case s' of [] -> [] (_:s'') -> lines_ s'' -- | the indentation used for pretty printing indentWith :: Int indentWith = 4 Cabal-1.22.5.0/Distribution/ReadE.hs0000644000000000000000000000263212627136220015126 0ustar0000000000000000----------------------------------------------------------------------------- -- | -- Module : Distribution.ReadE -- Copyright : Jose Iborra 2008 -- License : BSD3 -- -- Maintainer : cabal-devel@haskell.org -- Portability : portable -- -- Simple parsing with failure module Distribution.ReadE ( -- * ReadE ReadE(..), succeedReadE, failReadE, -- * Projections parseReadE, readEOrFail, readP_to_E ) where import Distribution.Compat.ReadP import Data.Char ( isSpace ) -- | Parser with simple error reporting newtype ReadE a = ReadE {runReadE :: String -> Either ErrorMsg a} type ErrorMsg = String instance Functor ReadE where fmap f (ReadE p) = ReadE $ \txt -> case p txt of Right a -> Right (f a) Left err -> Left err succeedReadE :: (String -> a) -> ReadE a succeedReadE f = ReadE (Right . f) failReadE :: ErrorMsg -> ReadE a failReadE = ReadE . const . Left parseReadE :: ReadE a -> ReadP r a parseReadE (ReadE p) = do txt <- look either fail return (p txt) readEOrFail :: ReadE a -> String -> a readEOrFail r = either error id . runReadE r readP_to_E :: (String -> ErrorMsg) -> ReadP a a -> ReadE a readP_to_E err r = ReadE $ \txt -> case [ p | (p, s) <- readP_to_S r txt , all isSpace s ] of [] -> Left (err txt) (p:_) -> Right p Cabal-1.22.5.0/Distribution/Simple.hs0000644000000000000000000007243112627136220015403 0ustar0000000000000000----------------------------------------------------------------------------- -- | -- Module : Distribution.Simple -- Copyright : Isaac Jones 2003-2005 -- License : BSD3 -- -- Maintainer : cabal-devel@haskell.org -- Portability : portable -- -- This is the command line front end to the Simple build system. When given -- the parsed command-line args and package information, is able to perform -- basic commands like configure, build, install, register, etc. -- -- This module exports the main functions that Setup.hs scripts use. It -- re-exports the 'UserHooks' type, the standard entry points like -- 'defaultMain' and 'defaultMainWithHooks' and the predefined sets of -- 'UserHooks' that custom @Setup.hs@ scripts can extend to add their own -- behaviour. -- -- This module isn't called \"Simple\" because it's simple. Far from -- it. It's called \"Simple\" because it does complicated things to -- simple software. -- -- The original idea was that there could be different build systems that all -- presented the same compatible command line interfaces. There is still a -- "Distribution.Make" system but in practice no packages use it. {- Work around this warning: libraries/Cabal/Distribution/Simple.hs:78:0: Warning: In the use of `runTests' (imported from Distribution.Simple.UserHooks): Deprecated: "Please use the new testing interface instead!" -} {-# OPTIONS_GHC -fno-warn-deprecations #-} module Distribution.Simple ( module Distribution.Package, module Distribution.Version, module Distribution.License, module Distribution.Simple.Compiler, module Language.Haskell.Extension, -- * Simple interface defaultMain, defaultMainNoRead, defaultMainArgs, -- * Customization UserHooks(..), Args, defaultMainWithHooks, defaultMainWithHooksArgs, -- ** Standard sets of hooks simpleUserHooks, autoconfUserHooks, defaultUserHooks, emptyUserHooks, -- ** Utils defaultHookedPackageDesc ) where -- local import Distribution.Simple.Compiler hiding (Flag) import Distribution.Simple.UserHooks import Distribution.Package --must not specify imports, since we're exporting module. import Distribution.PackageDescription ( PackageDescription(..), GenericPackageDescription, Executable(..) , updatePackageDescription, hasLibs , HookedBuildInfo, emptyHookedBuildInfo ) import Distribution.PackageDescription.Parse ( readPackageDescription, readHookedBuildInfo ) import Distribution.PackageDescription.Configuration ( flattenPackageDescription ) import Distribution.Simple.Program ( defaultProgramConfiguration, addKnownPrograms, builtinPrograms , restoreProgramConfiguration, reconfigurePrograms ) import Distribution.Simple.PreProcess (knownSuffixHandlers, PPSuffixHandler) import Distribution.Simple.Setup import Distribution.Simple.Command import Distribution.Simple.Build ( build, repl ) import Distribution.Simple.SrcDist ( sdist ) import Distribution.Simple.Register ( register, unregister ) import Distribution.Simple.Configure ( getPersistBuildConfig, maybeGetPersistBuildConfig , writePersistBuildConfig, checkPersistBuildConfigOutdated , configure, checkForeignDeps ) import Distribution.Simple.LocalBuildInfo ( LocalBuildInfo(..) ) import Distribution.Simple.Bench (bench) import Distribution.Simple.BuildPaths ( srcPref) import Distribution.Simple.Test (test) import Distribution.Simple.Install (install) import Distribution.Simple.Haddock (haddock, hscolour) import Distribution.Simple.Utils (die, notice, info, warn, setupMessage, chattyTry, defaultPackageDesc, defaultHookedPackageDesc, rawSystemExitWithEnv, cabalVersion, topHandler ) import Distribution.System ( OS(..), buildOS ) import Distribution.Verbosity import Language.Haskell.Extension import Distribution.Version import Distribution.License import Distribution.Text ( display ) -- Base import System.Environment(getArgs, getProgName) import System.Directory(removeFile, doesFileExist, doesDirectoryExist, removeDirectoryRecursive) import System.Exit (exitWith,ExitCode(..)) import System.IO.Error (isDoesNotExistError) import Control.Exception (throwIO) import Distribution.Compat.Environment (getEnvironment) import Distribution.Compat.Exception (catchIO) import Control.Monad (when) import Data.List (intercalate, unionBy, nub, (\\)) -- | A simple implementation of @main@ for a Cabal setup script. -- It reads the package description file using IO, and performs the -- action specified on the command line. defaultMain :: IO () defaultMain = getArgs >>= defaultMainHelper simpleUserHooks -- | A version of 'defaultMain' that is passed the command line -- arguments, rather than getting them from the environment. defaultMainArgs :: [String] -> IO () defaultMainArgs = defaultMainHelper simpleUserHooks -- | A customizable version of 'defaultMain'. defaultMainWithHooks :: UserHooks -> IO () defaultMainWithHooks hooks = getArgs >>= defaultMainHelper hooks -- | A customizable version of 'defaultMain' that also takes the command -- line arguments. defaultMainWithHooksArgs :: UserHooks -> [String] -> IO () defaultMainWithHooksArgs = defaultMainHelper -- | Like 'defaultMain', but accepts the package description as input -- rather than using IO to read it. defaultMainNoRead :: GenericPackageDescription -> IO () defaultMainNoRead pkg_descr = getArgs >>= defaultMainHelper simpleUserHooks { readDesc = return (Just pkg_descr) } defaultMainHelper :: UserHooks -> Args -> IO () defaultMainHelper hooks args = topHandler $ case commandsRun (globalCommand commands) commands args of CommandHelp help -> printHelp help CommandList opts -> printOptionsList opts CommandErrors errs -> printErrors errs CommandReadyToGo (flags, commandParse) -> case commandParse of _ | fromFlag (globalVersion flags) -> printVersion | fromFlag (globalNumericVersion flags) -> printNumericVersion CommandHelp help -> printHelp help CommandList opts -> printOptionsList opts CommandErrors errs -> printErrors errs CommandReadyToGo action -> action where printHelp help = getProgName >>= putStr . help printOptionsList = putStr . unlines printErrors errs = do putStr (intercalate "\n" errs) exitWith (ExitFailure 1) printNumericVersion = putStrLn $ display cabalVersion printVersion = putStrLn $ "Cabal library version " ++ display cabalVersion progs = addKnownPrograms (hookedPrograms hooks) defaultProgramConfiguration commands = [configureCommand progs `commandAddAction` \fs as -> configureAction hooks fs as >> return () ,buildCommand progs `commandAddAction` buildAction hooks ,replCommand progs `commandAddAction` replAction hooks ,installCommand `commandAddAction` installAction hooks ,copyCommand `commandAddAction` copyAction hooks ,haddockCommand `commandAddAction` haddockAction hooks ,cleanCommand `commandAddAction` cleanAction hooks ,sdistCommand `commandAddAction` sdistAction hooks ,hscolourCommand `commandAddAction` hscolourAction hooks ,registerCommand `commandAddAction` registerAction hooks ,unregisterCommand `commandAddAction` unregisterAction hooks ,testCommand `commandAddAction` testAction hooks ,benchmarkCommand `commandAddAction` benchAction hooks ] -- | Combine the preprocessors in the given hooks with the -- preprocessors built into cabal. allSuffixHandlers :: UserHooks -> [PPSuffixHandler] allSuffixHandlers hooks = overridesPP (hookedPreProcessors hooks) knownSuffixHandlers where overridesPP :: [PPSuffixHandler] -> [PPSuffixHandler] -> [PPSuffixHandler] overridesPP = unionBy (\x y -> fst x == fst y) configureAction :: UserHooks -> ConfigFlags -> Args -> IO LocalBuildInfo configureAction hooks flags args = do let distPref = fromFlag $ configDistPref flags pbi <- preConf hooks args flags (mb_pd_file, pkg_descr0) <- confPkgDescr -- get_pkg_descr (configVerbosity flags') --let pkg_descr = updatePackageDescription pbi pkg_descr0 let epkg_descr = (pkg_descr0, pbi) --(warns, ers) <- sanityCheckPackage pkg_descr --errorOut (configVerbosity flags') warns ers localbuildinfo0 <- confHook hooks epkg_descr flags -- remember the .cabal filename if we know it -- and all the extra command line args let localbuildinfo = localbuildinfo0 { pkgDescrFile = mb_pd_file, extraConfigArgs = args } writePersistBuildConfig distPref localbuildinfo let pkg_descr = localPkgDescr localbuildinfo postConf hooks args flags pkg_descr localbuildinfo return localbuildinfo where verbosity = fromFlag (configVerbosity flags) confPkgDescr :: IO (Maybe FilePath, GenericPackageDescription) confPkgDescr = do mdescr <- readDesc hooks case mdescr of Just descr -> return (Nothing, descr) Nothing -> do pdfile <- defaultPackageDesc verbosity descr <- readPackageDescription verbosity pdfile return (Just pdfile, descr) buildAction :: UserHooks -> BuildFlags -> Args -> IO () buildAction hooks flags args = do let distPref = fromFlag $ buildDistPref flags verbosity = fromFlag $ buildVerbosity flags lbi <- getBuildConfig hooks verbosity distPref progs <- reconfigurePrograms verbosity (buildProgramPaths flags) (buildProgramArgs flags) (withPrograms lbi) hookedAction preBuild buildHook postBuild (return lbi { withPrograms = progs }) hooks flags { buildArgs = args } args replAction :: UserHooks -> ReplFlags -> Args -> IO () replAction hooks flags args = do let distPref = fromFlag $ replDistPref flags verbosity = fromFlag $ replVerbosity flags lbi <- getBuildConfig hooks verbosity distPref progs <- reconfigurePrograms verbosity (replProgramPaths flags) (replProgramArgs flags) (withPrograms lbi) pbi <- preRepl hooks args flags let lbi' = lbi { withPrograms = progs } pkg_descr0 = localPkgDescr lbi' pkg_descr = updatePackageDescription pbi pkg_descr0 replHook hooks pkg_descr lbi' hooks flags args postRepl hooks args flags pkg_descr lbi' hscolourAction :: UserHooks -> HscolourFlags -> Args -> IO () hscolourAction hooks flags args = do let distPref = fromFlag $ hscolourDistPref flags verbosity = fromFlag $ hscolourVerbosity flags hookedAction preHscolour hscolourHook postHscolour (getBuildConfig hooks verbosity distPref) hooks flags args haddockAction :: UserHooks -> HaddockFlags -> Args -> IO () haddockAction hooks flags args = do let distPref = fromFlag $ haddockDistPref flags verbosity = fromFlag $ haddockVerbosity flags lbi <- getBuildConfig hooks verbosity distPref progs <- reconfigurePrograms verbosity (haddockProgramPaths flags) (haddockProgramArgs flags) (withPrograms lbi) hookedAction preHaddock haddockHook postHaddock (return lbi { withPrograms = progs }) hooks flags args cleanAction :: UserHooks -> CleanFlags -> Args -> IO () cleanAction hooks flags args = do pbi <- preClean hooks args flags pdfile <- defaultPackageDesc verbosity ppd <- readPackageDescription verbosity pdfile let pkg_descr0 = flattenPackageDescription ppd -- We don't sanity check for clean as an error -- here would prevent cleaning: --sanityCheckHookedBuildInfo pkg_descr0 pbi let pkg_descr = updatePackageDescription pbi pkg_descr0 cleanHook hooks pkg_descr () hooks flags postClean hooks args flags pkg_descr () where verbosity = fromFlag (cleanVerbosity flags) copyAction :: UserHooks -> CopyFlags -> Args -> IO () copyAction hooks flags args = do let distPref = fromFlag $ copyDistPref flags verbosity = fromFlag $ copyVerbosity flags hookedAction preCopy copyHook postCopy (getBuildConfig hooks verbosity distPref) hooks flags args installAction :: UserHooks -> InstallFlags -> Args -> IO () installAction hooks flags args = do let distPref = fromFlag $ installDistPref flags verbosity = fromFlag $ installVerbosity flags hookedAction preInst instHook postInst (getBuildConfig hooks verbosity distPref) hooks flags args sdistAction :: UserHooks -> SDistFlags -> Args -> IO () sdistAction hooks flags args = do let distPref = fromFlag $ sDistDistPref flags pbi <- preSDist hooks args flags mlbi <- maybeGetPersistBuildConfig distPref pdfile <- defaultPackageDesc verbosity ppd <- readPackageDescription verbosity pdfile let pkg_descr0 = flattenPackageDescription ppd sanityCheckHookedBuildInfo pkg_descr0 pbi let pkg_descr = updatePackageDescription pbi pkg_descr0 sDistHook hooks pkg_descr mlbi hooks flags postSDist hooks args flags pkg_descr mlbi where verbosity = fromFlag (sDistVerbosity flags) testAction :: UserHooks -> TestFlags -> Args -> IO () testAction hooks flags args = do let distPref = fromFlag $ testDistPref flags verbosity = fromFlag $ testVerbosity flags localBuildInfo <- getBuildConfig hooks verbosity distPref let pkg_descr = localPkgDescr localBuildInfo -- It is safe to do 'runTests' before the new test handler because the -- default action is a no-op and if the package uses the old test interface -- the new handler will find no tests. runTests hooks args False pkg_descr localBuildInfo hookedActionWithArgs preTest testHook postTest (getBuildConfig hooks verbosity distPref) hooks flags args benchAction :: UserHooks -> BenchmarkFlags -> Args -> IO () benchAction hooks flags args = do let distPref = fromFlag $ benchmarkDistPref flags verbosity = fromFlag $ benchmarkVerbosity flags hookedActionWithArgs preBench benchHook postBench (getBuildConfig hooks verbosity distPref) hooks flags args registerAction :: UserHooks -> RegisterFlags -> Args -> IO () registerAction hooks flags args = do let distPref = fromFlag $ regDistPref flags verbosity = fromFlag $ regVerbosity flags hookedAction preReg regHook postReg (getBuildConfig hooks verbosity distPref) hooks flags args unregisterAction :: UserHooks -> RegisterFlags -> Args -> IO () unregisterAction hooks flags args = do let distPref = fromFlag $ regDistPref flags verbosity = fromFlag $ regVerbosity flags hookedAction preUnreg unregHook postUnreg (getBuildConfig hooks verbosity distPref) hooks flags args hookedAction :: (UserHooks -> Args -> flags -> IO HookedBuildInfo) -> (UserHooks -> PackageDescription -> LocalBuildInfo -> UserHooks -> flags -> IO ()) -> (UserHooks -> Args -> flags -> PackageDescription -> LocalBuildInfo -> IO ()) -> IO LocalBuildInfo -> UserHooks -> flags -> Args -> IO () hookedAction pre_hook cmd_hook = hookedActionWithArgs pre_hook (\h _ pd lbi uh flags -> cmd_hook h pd lbi uh flags) hookedActionWithArgs :: (UserHooks -> Args -> flags -> IO HookedBuildInfo) -> (UserHooks -> Args -> PackageDescription -> LocalBuildInfo -> UserHooks -> flags -> IO ()) -> (UserHooks -> Args -> flags -> PackageDescription -> LocalBuildInfo -> IO ()) -> IO LocalBuildInfo -> UserHooks -> flags -> Args -> IO () hookedActionWithArgs pre_hook cmd_hook post_hook get_build_config hooks flags args = do pbi <- pre_hook hooks args flags localbuildinfo <- get_build_config let pkg_descr0 = localPkgDescr localbuildinfo --pkg_descr0 <- get_pkg_descr (get_verbose flags) sanityCheckHookedBuildInfo pkg_descr0 pbi let pkg_descr = updatePackageDescription pbi pkg_descr0 -- TODO: should we write the modified package descr back to the -- localbuildinfo? cmd_hook hooks args pkg_descr localbuildinfo hooks flags post_hook hooks args flags pkg_descr localbuildinfo sanityCheckHookedBuildInfo :: PackageDescription -> HookedBuildInfo -> IO () sanityCheckHookedBuildInfo PackageDescription { library = Nothing } (Just _,_) = die $ "The buildinfo contains info for a library, " ++ "but the package does not have a library." sanityCheckHookedBuildInfo pkg_descr (_, hookExes) | not (null nonExistant) = die $ "The buildinfo contains info for an executable called '" ++ head nonExistant ++ "' but the package does not have a " ++ "executable with that name." where pkgExeNames = nub (map exeName (executables pkg_descr)) hookExeNames = nub (map fst hookExes) nonExistant = hookExeNames \\ pkgExeNames sanityCheckHookedBuildInfo _ _ = return () getBuildConfig :: UserHooks -> Verbosity -> FilePath -> IO LocalBuildInfo getBuildConfig hooks verbosity distPref = do lbi_wo_programs <- getPersistBuildConfig distPref -- Restore info about unconfigured programs, since it is not serialized let lbi = lbi_wo_programs { withPrograms = restoreProgramConfiguration (builtinPrograms ++ hookedPrograms hooks) (withPrograms lbi_wo_programs) } case pkgDescrFile lbi of Nothing -> return lbi Just pkg_descr_file -> do outdated <- checkPersistBuildConfigOutdated distPref pkg_descr_file if outdated then reconfigure pkg_descr_file lbi else return lbi where reconfigure :: FilePath -> LocalBuildInfo -> IO LocalBuildInfo reconfigure pkg_descr_file lbi = do notice verbosity $ pkg_descr_file ++ " has been changed. " ++ "Re-configuring with most recently used options. " ++ "If this fails, please run configure manually.\n" let cFlags = configFlags lbi let cFlags' = cFlags { -- Since the list of unconfigured programs is not serialized, -- restore it to the same value as normally used at the beginning -- of a configure run: configPrograms = restoreProgramConfiguration (builtinPrograms ++ hookedPrograms hooks) (configPrograms cFlags), -- Use the current, not saved verbosity level: configVerbosity = Flag verbosity } configureAction hooks cFlags' (extraConfigArgs lbi) -- -------------------------------------------------------------------------- -- Cleaning clean :: PackageDescription -> CleanFlags -> IO () clean pkg_descr flags = do let distPref = fromFlag $ cleanDistPref flags notice verbosity "cleaning..." maybeConfig <- if fromFlag (cleanSaveConf flags) then maybeGetPersistBuildConfig distPref else return Nothing -- remove the whole dist/ directory rather than tracking exactly what files -- we created in there. chattyTry "removing dist/" $ do exists <- doesDirectoryExist distPref when exists (removeDirectoryRecursive distPref) -- Any extra files the user wants to remove mapM_ removeFileOrDirectory (extraTmpFiles pkg_descr) -- If the user wanted to save the config, write it back maybe (return ()) (writePersistBuildConfig distPref) maybeConfig where removeFileOrDirectory :: FilePath -> IO () removeFileOrDirectory fname = do isDir <- doesDirectoryExist fname isFile <- doesFileExist fname if isDir then removeDirectoryRecursive fname else when isFile $ removeFile fname verbosity = fromFlag (cleanVerbosity flags) -- -------------------------------------------------------------------------- -- Default hooks -- | Hooks that correspond to a plain instantiation of the -- \"simple\" build system simpleUserHooks :: UserHooks simpleUserHooks = emptyUserHooks { confHook = configure, postConf = finalChecks, buildHook = defaultBuildHook, replHook = defaultReplHook, copyHook = \desc lbi _ f -> install desc lbi f, -- has correct 'copy' behavior with params testHook = defaultTestHook, benchHook = defaultBenchHook, instHook = defaultInstallHook, sDistHook = \p l h f -> sdist p l f srcPref (allSuffixHandlers h), cleanHook = \p _ _ f -> clean p f, hscolourHook = \p l h f -> hscolour p l (allSuffixHandlers h) f, haddockHook = \p l h f -> haddock p l (allSuffixHandlers h) f, regHook = defaultRegHook, unregHook = \p l _ f -> unregister p l f } where finalChecks _args flags pkg_descr lbi = checkForeignDeps pkg_descr lbi (lessVerbose verbosity) where verbosity = fromFlag (configVerbosity flags) -- | Basic autoconf 'UserHooks': -- -- * 'postConf' runs @.\/configure@, if present. -- -- * the pre-hooks 'preBuild', 'preClean', 'preCopy', 'preInst', -- 'preReg' and 'preUnreg' read additional build information from -- /package/@.buildinfo@, if present. -- -- Thus @configure@ can use local system information to generate -- /package/@.buildinfo@ and possibly other files. {-# DEPRECATED defaultUserHooks "Use simpleUserHooks or autoconfUserHooks, unless you need Cabal-1.2\n compatibility in which case you must stick with defaultUserHooks" #-} defaultUserHooks :: UserHooks defaultUserHooks = autoconfUserHooks { confHook = \pkg flags -> do let verbosity = fromFlag (configVerbosity flags) warn verbosity "defaultUserHooks in Setup script is deprecated." confHook autoconfUserHooks pkg flags, postConf = oldCompatPostConf } -- This is the annoying old version that only runs configure if it exists. -- It's here for compatibility with existing Setup.hs scripts. See: -- https://github.com/haskell/cabal/issues/158 where oldCompatPostConf args flags pkg_descr lbi = do let verbosity = fromFlag (configVerbosity flags) noExtraFlags args confExists <- doesFileExist "configure" when confExists $ runConfigureScript verbosity backwardsCompatHack flags lbi pbi <- getHookedBuildInfo verbosity sanityCheckHookedBuildInfo pkg_descr pbi let pkg_descr' = updatePackageDescription pbi pkg_descr postConf simpleUserHooks args flags pkg_descr' lbi backwardsCompatHack = True autoconfUserHooks :: UserHooks autoconfUserHooks = simpleUserHooks { postConf = defaultPostConf, preBuild = \_ flags -> -- not using 'readHook' here because 'build' takes -- extra args getHookedBuildInfo $ fromFlag $ buildVerbosity flags, preClean = readHook cleanVerbosity, preCopy = readHook copyVerbosity, preInst = readHook installVerbosity, preHscolour = readHook hscolourVerbosity, preHaddock = readHook haddockVerbosity, preReg = readHook regVerbosity, preUnreg = readHook regVerbosity } where defaultPostConf :: Args -> ConfigFlags -> PackageDescription -> LocalBuildInfo -> IO () defaultPostConf args flags pkg_descr lbi = do let verbosity = fromFlag (configVerbosity flags) noExtraFlags args confExists <- doesFileExist "configure" if confExists then runConfigureScript verbosity backwardsCompatHack flags lbi else die "configure script not found." pbi <- getHookedBuildInfo verbosity sanityCheckHookedBuildInfo pkg_descr pbi let pkg_descr' = updatePackageDescription pbi pkg_descr postConf simpleUserHooks args flags pkg_descr' lbi backwardsCompatHack = False readHook :: (a -> Flag Verbosity) -> Args -> a -> IO HookedBuildInfo readHook get_verbosity a flags = do noExtraFlags a getHookedBuildInfo verbosity where verbosity = fromFlag (get_verbosity flags) runConfigureScript :: Verbosity -> Bool -> ConfigFlags -> LocalBuildInfo -> IO () runConfigureScript verbosity backwardsCompatHack flags lbi = do env <- getEnvironment let programConfig = withPrograms lbi (ccProg, ccFlags) <- configureCCompiler verbosity programConfig -- The C compiler's compilation and linker flags (e.g. -- "C compiler flags" and "Gcc Linker flags" from GHC) have already -- been merged into ccFlags, so we set both CFLAGS and LDFLAGS -- to ccFlags -- We don't try and tell configure which ld to use, as we don't have -- a way to pass its flags too let env' = appendToEnvironment ("CFLAGS", unwords ccFlags) env args' = args ++ ["--with-gcc=" ++ ccProg] handleNoWindowsSH $ rawSystemExitWithEnv verbosity "sh" args' env' where args = "./configure" : configureArgs backwardsCompatHack flags appendToEnvironment (key, val) [] = [(key, val)] appendToEnvironment (key, val) (kv@(k, v) : rest) | key == k = (key, v ++ " " ++ val) : rest | otherwise = kv : appendToEnvironment (key, val) rest handleNoWindowsSH action | buildOS /= Windows = action | otherwise = action `catchIO` \ioe -> if isDoesNotExistError ioe then die notFoundMsg else throwIO ioe notFoundMsg = "The package has a './configure' script. This requires a " ++ "Unix compatibility toolchain such as MinGW+MSYS or Cygwin." getHookedBuildInfo :: Verbosity -> IO HookedBuildInfo getHookedBuildInfo verbosity = do maybe_infoFile <- defaultHookedPackageDesc case maybe_infoFile of Nothing -> return emptyHookedBuildInfo Just infoFile -> do info verbosity $ "Reading parameters from " ++ infoFile readHookedBuildInfo verbosity infoFile defaultTestHook :: Args -> PackageDescription -> LocalBuildInfo -> UserHooks -> TestFlags -> IO () defaultTestHook args pkg_descr localbuildinfo _ flags = test args pkg_descr localbuildinfo flags defaultBenchHook :: Args -> PackageDescription -> LocalBuildInfo -> UserHooks -> BenchmarkFlags -> IO () defaultBenchHook args pkg_descr localbuildinfo _ flags = bench args pkg_descr localbuildinfo flags defaultInstallHook :: PackageDescription -> LocalBuildInfo -> UserHooks -> InstallFlags -> IO () defaultInstallHook pkg_descr localbuildinfo _ flags = do let copyFlags = defaultCopyFlags { copyDistPref = installDistPref flags, copyDest = toFlag NoCopyDest, copyVerbosity = installVerbosity flags } install pkg_descr localbuildinfo copyFlags let registerFlags = defaultRegisterFlags { regDistPref = installDistPref flags, regInPlace = installInPlace flags, regPackageDB = installPackageDB flags, regVerbosity = installVerbosity flags } when (hasLibs pkg_descr) $ register pkg_descr localbuildinfo registerFlags defaultBuildHook :: PackageDescription -> LocalBuildInfo -> UserHooks -> BuildFlags -> IO () defaultBuildHook pkg_descr localbuildinfo hooks flags = build pkg_descr localbuildinfo flags (allSuffixHandlers hooks) defaultReplHook :: PackageDescription -> LocalBuildInfo -> UserHooks -> ReplFlags -> [String] -> IO () defaultReplHook pkg_descr localbuildinfo hooks flags args = repl pkg_descr localbuildinfo flags (allSuffixHandlers hooks) args defaultRegHook :: PackageDescription -> LocalBuildInfo -> UserHooks -> RegisterFlags -> IO () defaultRegHook pkg_descr localbuildinfo _ flags = if hasLibs pkg_descr then register pkg_descr localbuildinfo flags else setupMessage verbosity "Package contains no library to register:" (packageId pkg_descr) where verbosity = fromFlag (regVerbosity flags) Cabal-1.22.5.0/Distribution/System.hs0000644000000000000000000001620012627136220015426 0ustar0000000000000000{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-} ----------------------------------------------------------------------------- -- | -- Module : Distribution.System -- Copyright : Duncan Coutts 2007-2008 -- -- Maintainer : cabal-devel@haskell.org -- Portability : portable -- -- Cabal often needs to do slightly different things on specific platforms. You -- probably know about the 'System.Info.os' however using that is very -- inconvenient because it is a string and different Haskell implementations -- do not agree on using the same strings for the same platforms! (In -- particular see the controversy over \"windows\" vs \"ming32\"). So to make it -- more consistent and easy to use we have an 'OS' enumeration. -- module Distribution.System ( -- * Operating System OS(..), buildOS, -- * Machine Architecture Arch(..), buildArch, -- * Platform is a pair of arch and OS Platform(..), buildPlatform, platformFromTriple ) where import qualified System.Info (os, arch) import qualified Data.Char as Char (toLower, isAlphaNum) import Distribution.Compat.Binary (Binary) import Data.Data (Data) import Data.Typeable (Typeable) import Data.Maybe (fromMaybe, listToMaybe) import Distribution.Text (Text(..), display) import qualified Distribution.Compat.ReadP as Parse import GHC.Generics (Generic) import qualified Text.PrettyPrint as Disp import Text.PrettyPrint ((<>)) -- | How strict to be when classifying strings into the 'OS' and 'Arch' enums. -- -- The reason we have multiple ways to do the classification is because there -- are two situations where we need to do it. -- -- For parsing OS and arch names in .cabal files we really want everyone to be -- referring to the same or or arch by the same name. Variety is not a virtue -- in this case. We don't mind about case though. -- -- For the System.Info.os\/arch different Haskell implementations use different -- names for the same or\/arch. Also they tend to distinguish versions of an -- OS\/arch which we just don't care about. -- -- The 'Compat' classification allows us to recognise aliases that are already -- in common use but it allows us to distinguish them from the canonical name -- which enables us to warn about such deprecated aliases. -- data ClassificationStrictness = Permissive | Compat | Strict -- ------------------------------------------------------------ -- * Operating System -- ------------------------------------------------------------ data OS = Linux | Windows | OSX -- tier 1 desktop OSs | FreeBSD | OpenBSD | NetBSD -- other free Unix OSs | DragonFly | Solaris | AIX | HPUX | IRIX -- ageing Unix OSs | HaLVM -- bare metal / VMs / hypervisors | IOS -- iOS | Ghcjs | OtherOS String deriving (Eq, Generic, Ord, Show, Read, Typeable, Data) instance Binary OS --TODO: decide how to handle Android and iOS. -- They are like Linux and OSX but with some differences. -- Should they be separate from Linux/OS X, or a subtype? -- e.g. should we have os(linux) && os(android) true simultaneously? knownOSs :: [OS] knownOSs = [Linux, Windows, OSX ,FreeBSD, OpenBSD, NetBSD, DragonFly ,Solaris, AIX, HPUX, IRIX ,HaLVM ,IOS ,Ghcjs] osAliases :: ClassificationStrictness -> OS -> [String] osAliases Permissive Windows = ["mingw32", "win32", "cygwin32"] osAliases Compat Windows = ["mingw32", "win32"] osAliases _ OSX = ["darwin"] osAliases Permissive FreeBSD = ["kfreebsdgnu"] osAliases Compat FreeBSD = ["kfreebsdgnu"] osAliases Permissive Solaris = ["solaris2"] osAliases Compat Solaris = ["solaris2"] osAliases _ _ = [] instance Text OS where disp (OtherOS name) = Disp.text name disp other = Disp.text (lowercase (show other)) parse = fmap (classifyOS Compat) ident classifyOS :: ClassificationStrictness -> String -> OS classifyOS strictness s = fromMaybe (OtherOS s) $ lookup (lowercase s) osMap where osMap = [ (name, os) | os <- knownOSs , name <- display os : osAliases strictness os ] buildOS :: OS buildOS = classifyOS Permissive System.Info.os -- ------------------------------------------------------------ -- * Machine Architecture -- ------------------------------------------------------------ data Arch = I386 | X86_64 | PPC | PPC64 | Sparc | Arm | Mips | SH | IA64 | S390 | Alpha | Hppa | Rs6000 | M68k | Vax | JavaScript | OtherArch String deriving (Eq, Generic, Ord, Show, Read, Typeable, Data) instance Binary Arch knownArches :: [Arch] knownArches = [I386, X86_64, PPC, PPC64, Sparc ,Arm, Mips, SH ,IA64, S390 ,Alpha, Hppa, Rs6000 ,M68k, Vax ,JavaScript] archAliases :: ClassificationStrictness -> Arch -> [String] archAliases Strict _ = [] archAliases Compat _ = [] archAliases _ PPC = ["powerpc"] archAliases _ PPC64 = ["powerpc64"] archAliases _ Sparc = ["sparc64", "sun4"] archAliases _ Mips = ["mipsel", "mipseb"] archAliases _ Arm = ["armeb", "armel"] archAliases _ _ = [] instance Text Arch where disp (OtherArch name) = Disp.text name disp other = Disp.text (lowercase (show other)) parse = fmap (classifyArch Strict) ident classifyArch :: ClassificationStrictness -> String -> Arch classifyArch strictness s = fromMaybe (OtherArch s) $ lookup (lowercase s) archMap where archMap = [ (name, arch) | arch <- knownArches , name <- display arch : archAliases strictness arch ] buildArch :: Arch buildArch = classifyArch Permissive System.Info.arch -- ------------------------------------------------------------ -- * Platform -- ------------------------------------------------------------ data Platform = Platform Arch OS deriving (Eq, Generic, Ord, Show, Read, Typeable, Data) instance Binary Platform instance Text Platform where disp (Platform arch os) = disp arch <> Disp.char '-' <> disp os parse = do arch <- parse _ <- Parse.char '-' os <- parse return (Platform arch os) -- | The platform Cabal was compiled on. In most cases, -- @LocalBuildInfo.hostPlatform@ should be used instead (the platform we're -- targeting). buildPlatform :: Platform buildPlatform = Platform buildArch buildOS -- Utils: ident :: Parse.ReadP r String ident = Parse.munch1 (\c -> Char.isAlphaNum c || c == '_' || c == '-') --TODO: probably should disallow starting with a number lowercase :: String -> String lowercase = map Char.toLower platformFromTriple :: String -> Maybe Platform platformFromTriple triple = fmap fst (listToMaybe $ Parse.readP_to_S parseTriple triple) where parseWord = Parse.munch1 (\c -> Char.isAlphaNum c || c == '_') parseTriple = do arch <- fmap (classifyArch Strict) parseWord _ <- Parse.char '-' _ <- parseWord -- Skip vendor _ <- Parse.char '-' os <- fmap (classifyOS Compat) ident -- OS may have hyphens, like -- 'nto-qnx' return $ Platform arch os Cabal-1.22.5.0/Distribution/TestSuite.hs0000644000000000000000000000644412627136220016104 0ustar0000000000000000----------------------------------------------------------------------------- -- | -- Module : Distribution.TestSuite -- Copyright : Thomas Tuegel 2010 -- License : BSD3 -- -- Maintainer : cabal-devel@haskell.org -- Portability : portable -- -- This module defines the detailed test suite interface which makes it -- possible to expose individual tests to Cabal or other test agents. module Distribution.TestSuite ( TestInstance(..) , OptionDescr(..) , OptionType(..) , Test(..) , Options , Progress(..) , Result(..) , testGroup ) where data TestInstance = TestInstance { run :: IO Progress -- ^ Perform the test. , name :: String -- ^ A name for the test, unique within a -- test suite. , tags :: [String] -- ^ Users can select groups of tests by -- their tags. , options :: [OptionDescr] -- ^ Descriptions of the options recognized -- by this test. , setOption :: String -> String -> Either String TestInstance -- ^ Try to set the named option to the given value. Returns an error -- message if the option is not supported or the value could not be -- correctly parsed; otherwise, a 'TestInstance' with the option set to -- the given value is returned. } data OptionDescr = OptionDescr { optionName :: String , optionDescription :: String -- ^ A human-readable description of the -- option to guide the user setting it. , optionType :: OptionType , optionDefault :: Maybe String } deriving (Eq, Read, Show) data OptionType = OptionFile { optionFileMustExist :: Bool , optionFileIsDir :: Bool , optionFileExtensions :: [String] } | OptionString { optionStringMultiline :: Bool } | OptionNumber { optionNumberIsInt :: Bool , optionNumberBounds :: (Maybe String, Maybe String) } | OptionBool | OptionEnum [String] | OptionSet [String] | OptionRngSeed deriving (Eq, Read, Show) data Test = Test TestInstance | Group { groupName :: String , concurrently :: Bool -- ^ If true, then children of this group may be run in parallel. -- Note that this setting is not inherited by children. In -- particular, consider a group F with "concurrently = False" that -- has some children, including a group T with "concurrently = -- True". The children of group T may be run concurrently with each -- other, as long as none are run at the same time as any of the -- direct children of group F. , groupTests :: [Test] } | ExtraOptions [OptionDescr] Test type Options = [(String, String)] data Progress = Finished Result | Progress String (IO Progress) data Result = Pass | Fail String | Error String deriving (Eq, Read, Show) -- | Create a named group of tests, which are assumed to be safe to run in -- parallel. testGroup :: String -> [Test] -> Test testGroup n ts = Group { groupName = n, concurrently = True, groupTests = ts } Cabal-1.22.5.0/Distribution/Text.hs0000644000000000000000000000443212627136220015072 0ustar0000000000000000----------------------------------------------------------------------------- -- | -- Module : Distribution.Text -- Copyright : Duncan Coutts 2007 -- -- Maintainer : cabal-devel@haskell.org -- Portability : portable -- -- This defines a 'Text' class which is a bit like the 'Read' and 'Show' -- classes. The difference is that is uses a modern pretty printer and parser -- system and the format is not expected to be Haskell concrete syntax but -- rather the external human readable representation used by Cabal. -- module Distribution.Text ( Text(..), display, simpleParse, ) where import qualified Distribution.Compat.ReadP as Parse import qualified Text.PrettyPrint as Disp import Data.Version (Version(Version)) import qualified Data.Char as Char (isDigit, isAlphaNum, isSpace) class Text a where disp :: a -> Disp.Doc parse :: Parse.ReadP r a display :: Text a => a -> String display = Disp.renderStyle style . disp where style = Disp.Style { Disp.mode = Disp.PageMode, Disp.lineLength = 79, Disp.ribbonsPerLine = 1.0 } simpleParse :: Text a => String -> Maybe a simpleParse str = case [ p | (p, s) <- Parse.readP_to_S parse str , all Char.isSpace s ] of [] -> Nothing (p:_) -> Just p -- ----------------------------------------------------------------------------- -- Instances for types from the base package instance Text Bool where disp = Disp.text . show parse = Parse.choice [ (Parse.string "True" Parse.+++ Parse.string "true") >> return True , (Parse.string "False" Parse.+++ Parse.string "false") >> return False ] instance Text Version where disp (Version branch _tags) -- Death to version tags!! = Disp.hcat (Disp.punctuate (Disp.char '.') (map Disp.int branch)) parse = do branch <- Parse.sepBy1 digits (Parse.char '.') tags <- Parse.many (Parse.char '-' >> Parse.munch1 Char.isAlphaNum) return (Version branch tags) --TODO: should we ignore the tags? where digits = do first <- Parse.satisfy Char.isDigit if first == '0' then return 0 else do rest <- Parse.munch Char.isDigit return (read (first : rest)) Cabal-1.22.5.0/Distribution/Verbosity.hs0000644000000000000000000000521612627136220016135 0ustar0000000000000000{-# LANGUAGE DeriveGeneric #-} ----------------------------------------------------------------------------- -- | -- Module : Distribution.Verbosity -- Copyright : Ian Lynagh 2007 -- License : BSD3 -- -- Maintainer : cabal-devel@haskell.org -- Portability : portable -- -- A simple 'Verbosity' type with associated utilities. There are 4 standard -- verbosity levels from 'silent', 'normal', 'verbose' up to 'deafening'. This -- is used for deciding what logging messages to print. -- Verbosity for Cabal functions. module Distribution.Verbosity ( -- * Verbosity Verbosity, silent, normal, verbose, deafening, moreVerbose, lessVerbose, intToVerbosity, flagToVerbosity, showForCabal, showForGHC ) where import Distribution.Compat.Binary (Binary) import Data.List (elemIndex) import Distribution.ReadE import GHC.Generics data Verbosity = Silent | Normal | Verbose | Deafening deriving (Generic, Show, Read, Eq, Ord, Enum, Bounded) instance Binary Verbosity -- We shouldn't print /anything/ unless an error occurs in silent mode silent :: Verbosity silent = Silent -- Print stuff we want to see by default normal :: Verbosity normal = Normal -- Be more verbose about what's going on verbose :: Verbosity verbose = Verbose -- Not only are we verbose ourselves (perhaps even noisier than when -- being "verbose"), but we tell everything we run to be verbose too deafening :: Verbosity deafening = Deafening moreVerbose :: Verbosity -> Verbosity moreVerbose Silent = Silent --silent should stay silent moreVerbose Normal = Verbose moreVerbose Verbose = Deafening moreVerbose Deafening = Deafening lessVerbose :: Verbosity -> Verbosity lessVerbose Deafening = Deafening lessVerbose Verbose = Normal lessVerbose Normal = Silent lessVerbose Silent = Silent intToVerbosity :: Int -> Maybe Verbosity intToVerbosity 0 = Just Silent intToVerbosity 1 = Just Normal intToVerbosity 2 = Just Verbose intToVerbosity 3 = Just Deafening intToVerbosity _ = Nothing flagToVerbosity :: ReadE Verbosity flagToVerbosity = ReadE $ \s -> case reads s of [(i, "")] -> case intToVerbosity i of Just v -> Right v Nothing -> Left ("Bad verbosity: " ++ show i ++ ". Valid values are 0..3") _ -> Left ("Can't parse verbosity " ++ s) showForCabal, showForGHC :: Verbosity -> String showForCabal v = maybe (error "unknown verbosity") show $ elemIndex v [silent,normal,verbose,deafening] showForGHC v = maybe (error "unknown verbosity") show $ elemIndex v [silent,normal,__,verbose,deafening] where __ = silent -- this will be always ignored by elemIndex Cabal-1.22.5.0/Distribution/Version.hs0000644000000000000000000007107512627136220015602 0ustar0000000000000000{-# LANGUAGE CPP, DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-} #if __GLASGOW_HASKELL__ < 707 {-# LANGUAGE StandaloneDeriving #-} #endif {-# OPTIONS_GHC -fno-warn-orphans #-} ----------------------------------------------------------------------------- -- | -- Module : Distribution.Version -- Copyright : Isaac Jones, Simon Marlow 2003-2004 -- Duncan Coutts 2008 -- License : BSD3 -- -- Maintainer : cabal-devel@haskell.org -- Portability : portable -- -- Exports the 'Version' type along with a parser and pretty printer. A version -- is something like @\"1.3.3\"@. It also defines the 'VersionRange' data -- types. Version ranges are like @\">= 1.2 && < 2\"@. module Distribution.Version ( -- * Package versions Version(..), -- * Version ranges VersionRange(..), -- ** Constructing anyVersion, noVersion, thisVersion, notThisVersion, laterVersion, earlierVersion, orLaterVersion, orEarlierVersion, unionVersionRanges, intersectVersionRanges, withinVersion, betweenVersionsInclusive, -- ** Inspection withinRange, isAnyVersion, isNoVersion, isSpecificVersion, simplifyVersionRange, foldVersionRange, foldVersionRange', -- ** Modification removeUpperBound, -- * Version intervals view asVersionIntervals, VersionInterval, LowerBound(..), UpperBound(..), Bound(..), -- ** 'VersionIntervals' abstract type -- | The 'VersionIntervals' type and the accompanying functions are exposed -- primarily for completeness and testing purposes. In practice -- 'asVersionIntervals' is the main function to use to -- view a 'VersionRange' as a bunch of 'VersionInterval's. -- VersionIntervals, toVersionIntervals, fromVersionIntervals, withinIntervals, versionIntervals, mkVersionIntervals, unionVersionIntervals, intersectVersionIntervals, ) where import Distribution.Compat.Binary ( Binary(..) ) import Data.Data ( Data ) import Data.Typeable ( Typeable ) import Data.Version ( Version(..) ) import GHC.Generics ( Generic ) import Distribution.Text ( Text(..) ) import qualified Distribution.Compat.ReadP as Parse import Distribution.Compat.ReadP ((+++)) import qualified Text.PrettyPrint as Disp import Text.PrettyPrint ((<>), (<+>)) import qualified Data.Char as Char (isDigit) import Control.Exception (assert) -- ----------------------------------------------------------------------------- -- Version ranges -- Todo: maybe move this to Distribution.Package.Version? -- (package-specific versioning scheme). data VersionRange = AnyVersion | ThisVersion Version -- = version | LaterVersion Version -- > version (NB. not >=) | EarlierVersion Version -- < version | WildcardVersion Version -- == ver.* (same as >= ver && < ver+1) | UnionVersionRanges VersionRange VersionRange | IntersectVersionRanges VersionRange VersionRange | VersionRangeParens VersionRange -- just '(exp)' parentheses syntax deriving (Data, Eq, Generic, Read, Show, Typeable) instance Binary VersionRange #if __GLASGOW_HASKELL__ < 707 -- starting with ghc-7.7/base-4.7 this instance is provided in "Data.Data" deriving instance Data Version #endif -- Deriving this instance from Generic gives trouble on GHC 7.2 because the -- Generic instance has to be standalone-derived. So, we hand-roll our own. -- We can't use a generic Binary instance on later versions because we must -- maintain compatibility between compiler versions. instance Binary Version where get = do br <- get tags <- get return $ Version br tags put (Version br tags) = put br >> put tags {-# DEPRECATED AnyVersion "Use 'anyVersion', 'foldVersionRange' or 'asVersionIntervals'" #-} {-# DEPRECATED ThisVersion "use 'thisVersion', 'foldVersionRange' or 'asVersionIntervals'" #-} {-# DEPRECATED LaterVersion "use 'laterVersion', 'foldVersionRange' or 'asVersionIntervals'" #-} {-# DEPRECATED EarlierVersion "use 'earlierVersion', 'foldVersionRange' or 'asVersionIntervals'" #-} {-# DEPRECATED WildcardVersion "use 'anyVersion', 'foldVersionRange' or 'asVersionIntervals'" #-} {-# DEPRECATED UnionVersionRanges "use 'unionVersionRanges', 'foldVersionRange' or 'asVersionIntervals'" #-} {-# DEPRECATED IntersectVersionRanges "use 'intersectVersionRanges', 'foldVersionRange' or 'asVersionIntervals'" #-} -- | The version range @-any@. That is, a version range containing all -- versions. -- -- > withinRange v anyVersion = True -- anyVersion :: VersionRange anyVersion = AnyVersion -- | The empty version range, that is a version range containing no versions. -- -- This can be constructed using any unsatisfiable version range expression, -- for example @> 1 && < 1@. -- -- > withinRange v noVersion = False -- noVersion :: VersionRange noVersion = IntersectVersionRanges (LaterVersion v) (EarlierVersion v) where v = Version [1] [] -- | The version range @== v@ -- -- > withinRange v' (thisVersion v) = v' == v -- thisVersion :: Version -> VersionRange thisVersion = ThisVersion -- | The version range @< v || > v@ -- -- > withinRange v' (notThisVersion v) = v' /= v -- notThisVersion :: Version -> VersionRange notThisVersion v = UnionVersionRanges (EarlierVersion v) (LaterVersion v) -- | The version range @> v@ -- -- > withinRange v' (laterVersion v) = v' > v -- laterVersion :: Version -> VersionRange laterVersion = LaterVersion -- | The version range @>= v@ -- -- > withinRange v' (orLaterVersion v) = v' >= v -- orLaterVersion :: Version -> VersionRange orLaterVersion v = UnionVersionRanges (ThisVersion v) (LaterVersion v) -- | The version range @< v@ -- -- > withinRange v' (earlierVersion v) = v' < v -- earlierVersion :: Version -> VersionRange earlierVersion = EarlierVersion -- | The version range @<= v@ -- -- > withinRange v' (orEarlierVersion v) = v' <= v -- orEarlierVersion :: Version -> VersionRange orEarlierVersion v = UnionVersionRanges (ThisVersion v) (EarlierVersion v) -- | The version range @vr1 || vr2@ -- -- > withinRange v' (unionVersionRanges vr1 vr2) -- > = withinRange v' vr1 || withinRange v' vr2 -- unionVersionRanges :: VersionRange -> VersionRange -> VersionRange unionVersionRanges = UnionVersionRanges -- | The version range @vr1 && vr2@ -- -- > withinRange v' (intersectVersionRanges vr1 vr2) -- > = withinRange v' vr1 && withinRange v' vr2 -- intersectVersionRanges :: VersionRange -> VersionRange -> VersionRange intersectVersionRanges = IntersectVersionRanges -- | The version range @== v.*@. -- -- For example, for version @1.2@, the version range @== 1.2.*@ is the same as -- @>= 1.2 && < 1.3@ -- -- > withinRange v' (laterVersion v) = v' >= v && v' < upper v -- > where -- > upper (Version lower t) = Version (init lower ++ [last lower + 1]) t -- withinVersion :: Version -> VersionRange withinVersion = WildcardVersion -- | The version range @>= v1 && <= v2@. -- -- In practice this is not very useful because we normally use inclusive lower -- bounds and exclusive upper bounds. -- -- > withinRange v' (laterVersion v) = v' > v -- betweenVersionsInclusive :: Version -> Version -> VersionRange betweenVersionsInclusive v1 v2 = IntersectVersionRanges (orLaterVersion v1) (orEarlierVersion v2) {-# DEPRECATED betweenVersionsInclusive "In practice this is not very useful because we normally use inclusive lower bounds and exclusive upper bounds" #-} -- | Given a version range, remove the highest upper bound. Example: @(>= 1 && < -- 3) || (>= 4 && < 5)@ is converted to @(>= 1 && < 3) || (>= 4)@. removeUpperBound :: VersionRange -> VersionRange removeUpperBound = fromVersionIntervals . relaxLastInterval . toVersionIntervals where relaxLastInterval (VersionIntervals intervals) = VersionIntervals (relaxLastInterval' intervals) relaxLastInterval' [] = [] relaxLastInterval' [(l,_)] = [(l, NoUpperBound)] relaxLastInterval' (i:is) = i : relaxLastInterval' is -- | Fold over the basic syntactic structure of a 'VersionRange'. -- -- This provides a syntactic view of the expression defining the version range. -- The syntactic sugar @\">= v\"@, @\"<= v\"@ and @\"== v.*\"@ is presented -- in terms of the other basic syntax. -- -- For a semantic view use 'asVersionIntervals'. -- foldVersionRange :: a -- ^ @\"-any\"@ version -> (Version -> a) -- ^ @\"== v\"@ -> (Version -> a) -- ^ @\"> v\"@ -> (Version -> a) -- ^ @\"< v\"@ -> (a -> a -> a) -- ^ @\"_ || _\"@ union -> (a -> a -> a) -- ^ @\"_ && _\"@ intersection -> VersionRange -> a foldVersionRange anyv this later earlier union intersect = fold where fold AnyVersion = anyv fold (ThisVersion v) = this v fold (LaterVersion v) = later v fold (EarlierVersion v) = earlier v fold (WildcardVersion v) = fold (wildcard v) fold (UnionVersionRanges v1 v2) = union (fold v1) (fold v2) fold (IntersectVersionRanges v1 v2) = intersect (fold v1) (fold v2) fold (VersionRangeParens v) = fold v wildcard v = intersectVersionRanges (orLaterVersion v) (earlierVersion (wildcardUpperBound v)) -- | An extended variant of 'foldVersionRange' that also provides a view of -- in which the syntactic sugar @\">= v\"@, @\"<= v\"@ and @\"== v.*\"@ is presented -- explicitly rather than in terms of the other basic syntax. -- foldVersionRange' :: a -- ^ @\"-any\"@ version -> (Version -> a) -- ^ @\"== v\"@ -> (Version -> a) -- ^ @\"> v\"@ -> (Version -> a) -- ^ @\"< v\"@ -> (Version -> a) -- ^ @\">= v\"@ -> (Version -> a) -- ^ @\"<= v\"@ -> (Version -> Version -> a) -- ^ @\"== v.*\"@ wildcard. The -- function is passed the -- inclusive lower bound and the -- exclusive upper bounds of the -- range defined by the wildcard. -> (a -> a -> a) -- ^ @\"_ || _\"@ union -> (a -> a -> a) -- ^ @\"_ && _\"@ intersection -> (a -> a) -- ^ @\"(_)\"@ parentheses -> VersionRange -> a foldVersionRange' anyv this later earlier orLater orEarlier wildcard union intersect parens = fold where fold AnyVersion = anyv fold (ThisVersion v) = this v fold (LaterVersion v) = later v fold (EarlierVersion v) = earlier v fold (UnionVersionRanges (ThisVersion v) (LaterVersion v')) | v==v' = orLater v fold (UnionVersionRanges (LaterVersion v) (ThisVersion v')) | v==v' = orLater v fold (UnionVersionRanges (ThisVersion v) (EarlierVersion v')) | v==v' = orEarlier v fold (UnionVersionRanges (EarlierVersion v) (ThisVersion v')) | v==v' = orEarlier v fold (WildcardVersion v) = wildcard v (wildcardUpperBound v) fold (UnionVersionRanges v1 v2) = union (fold v1) (fold v2) fold (IntersectVersionRanges v1 v2) = intersect (fold v1) (fold v2) fold (VersionRangeParens v) = parens (fold v) -- | Does this version fall within the given range? -- -- This is the evaluation function for the 'VersionRange' type. -- withinRange :: Version -> VersionRange -> Bool withinRange v = foldVersionRange True (\v' -> versionBranch v == versionBranch v') (\v' -> versionBranch v > versionBranch v') (\v' -> versionBranch v < versionBranch v') (||) (&&) -- | View a 'VersionRange' as a union of intervals. -- -- This provides a canonical view of the semantics of a 'VersionRange' as -- opposed to the syntax of the expression used to define it. For the syntactic -- view use 'foldVersionRange'. -- -- Each interval is non-empty. The sequence is in increasing order and no -- intervals overlap or touch. Therefore only the first and last can be -- unbounded. The sequence can be empty if the range is empty -- (e.g. a range expression like @< 1 && > 2@). -- -- Other checks are trivial to implement using this view. For example: -- -- > isNoVersion vr | [] <- asVersionIntervals vr = True -- > | otherwise = False -- -- > isSpecificVersion vr -- > | [(LowerBound v InclusiveBound -- > ,UpperBound v' InclusiveBound)] <- asVersionIntervals vr -- > , v == v' = Just v -- > | otherwise = Nothing -- asVersionIntervals :: VersionRange -> [VersionInterval] asVersionIntervals = versionIntervals . toVersionIntervals -- | Does this 'VersionRange' place any restriction on the 'Version' or is it -- in fact equivalent to 'AnyVersion'. -- -- Note this is a semantic check, not simply a syntactic check. So for example -- the following is @True@ (for all @v@). -- -- > isAnyVersion (EarlierVersion v `UnionVersionRanges` orLaterVersion v) -- isAnyVersion :: VersionRange -> Bool isAnyVersion vr = case asVersionIntervals vr of [(LowerBound v InclusiveBound, NoUpperBound)] | isVersion0 v -> True _ -> False -- | This is the converse of 'isAnyVersion'. It check if the version range is -- empty, if there is no possible version that satisfies the version range. -- -- For example this is @True@ (for all @v@): -- -- > isNoVersion (EarlierVersion v `IntersectVersionRanges` LaterVersion v) -- isNoVersion :: VersionRange -> Bool isNoVersion vr = case asVersionIntervals vr of [] -> True _ -> False -- | Is this version range in fact just a specific version? -- -- For example the version range @\">= 3 && <= 3\"@ contains only the version -- @3@. -- isSpecificVersion :: VersionRange -> Maybe Version isSpecificVersion vr = case asVersionIntervals vr of [(LowerBound v InclusiveBound ,UpperBound v' InclusiveBound)] | v == v' -> Just v _ -> Nothing -- | Simplify a 'VersionRange' expression. For non-empty version ranges -- this produces a canonical form. Empty or inconsistent version ranges -- are left as-is because that provides more information. -- -- If you need a canonical form use -- @fromVersionIntervals . toVersionIntervals@ -- -- It satisfies the following properties: -- -- > withinRange v (simplifyVersionRange r) = withinRange v r -- -- > withinRange v r = withinRange v r' -- > ==> simplifyVersionRange r = simplifyVersionRange r' -- > || isNoVersion r -- > || isNoVersion r' -- simplifyVersionRange :: VersionRange -> VersionRange simplifyVersionRange vr -- If the version range is inconsistent then we just return the -- original since that has more information than ">1 && < 1", which -- is the canonical inconsistent version range. | null (versionIntervals vi) = vr | otherwise = fromVersionIntervals vi where vi = toVersionIntervals vr ---------------------------- -- Wildcard range utilities -- wildcardUpperBound :: Version -> Version wildcardUpperBound (Version lowerBound ts) = Version upperBound ts where upperBound = init lowerBound ++ [last lowerBound + 1] isWildcardRange :: Version -> Version -> Bool isWildcardRange (Version branch1 _) (Version branch2 _) = check branch1 branch2 where check (n:[]) (m:[]) | n+1 == m = True check (n:ns) (m:ms) | n == m = check ns ms check _ _ = False ------------------ -- Intervals view -- -- | A complementary representation of a 'VersionRange'. Instead of a boolean -- version predicate it uses an increasing sequence of non-overlapping, -- non-empty intervals. -- -- The key point is that this representation gives a canonical representation -- for the semantics of 'VersionRange's. This makes it easier to check things -- like whether a version range is empty, covers all versions, or requires a -- certain minimum or maximum version. It also makes it easy to check equality -- or containment. It also makes it easier to identify \'simple\' version -- predicates for translation into foreign packaging systems that do not -- support complex version range expressions. -- newtype VersionIntervals = VersionIntervals [VersionInterval] deriving (Eq, Show) -- | Inspect the list of version intervals. -- versionIntervals :: VersionIntervals -> [VersionInterval] versionIntervals (VersionIntervals is) = is type VersionInterval = (LowerBound, UpperBound) data LowerBound = LowerBound Version !Bound deriving (Eq, Show) data UpperBound = NoUpperBound | UpperBound Version !Bound deriving (Eq, Show) data Bound = ExclusiveBound | InclusiveBound deriving (Eq, Show) minLowerBound :: LowerBound minLowerBound = LowerBound (Version [0] []) InclusiveBound isVersion0 :: Version -> Bool isVersion0 (Version [0] _) = True isVersion0 _ = False instance Ord LowerBound where LowerBound ver bound <= LowerBound ver' bound' = case compare ver ver' of LT -> True EQ -> not (bound == ExclusiveBound && bound' == InclusiveBound) GT -> False instance Ord UpperBound where _ <= NoUpperBound = True NoUpperBound <= UpperBound _ _ = False UpperBound ver bound <= UpperBound ver' bound' = case compare ver ver' of LT -> True EQ -> not (bound == InclusiveBound && bound' == ExclusiveBound) GT -> False invariant :: VersionIntervals -> Bool invariant (VersionIntervals intervals) = all validInterval intervals && all doesNotTouch' adjacentIntervals where doesNotTouch' :: (VersionInterval, VersionInterval) -> Bool doesNotTouch' ((_,u), (l',_)) = doesNotTouch u l' adjacentIntervals :: [(VersionInterval, VersionInterval)] adjacentIntervals | null intervals = [] | otherwise = zip intervals (tail intervals) checkInvariant :: VersionIntervals -> VersionIntervals checkInvariant is = assert (invariant is) is -- | Directly construct a 'VersionIntervals' from a list of intervals. -- -- Each interval must be non-empty. The sequence must be in increasing order -- and no intervals may overlap or touch. If any of these conditions are not -- satisfied the function returns @Nothing@. -- mkVersionIntervals :: [VersionInterval] -> Maybe VersionIntervals mkVersionIntervals intervals | invariant (VersionIntervals intervals) = Just (VersionIntervals intervals) | otherwise = Nothing validVersion :: Version -> Bool validVersion (Version [] _) = False validVersion (Version vs _) = all (>=0) vs validInterval :: (LowerBound, UpperBound) -> Bool validInterval i@(l, u) = validLower l && validUpper u && nonEmpty i where validLower (LowerBound v _) = validVersion v validUpper NoUpperBound = True validUpper (UpperBound v _) = validVersion v -- Check an interval is non-empty -- nonEmpty :: VersionInterval -> Bool nonEmpty (_, NoUpperBound ) = True nonEmpty (LowerBound l lb, UpperBound u ub) = (l < u) || (l == u && lb == InclusiveBound && ub == InclusiveBound) -- Check an upper bound does not intersect, or even touch a lower bound: -- -- ---| or ---) but not ---] or ---) or ---] -- |--- (--- (--- [--- [--- -- doesNotTouch :: UpperBound -> LowerBound -> Bool doesNotTouch NoUpperBound _ = False doesNotTouch (UpperBound u ub) (LowerBound l lb) = u < l || (u == l && ub == ExclusiveBound && lb == ExclusiveBound) -- | Check an upper bound does not intersect a lower bound: -- -- ---| or ---) or ---] or ---) but not ---] -- |--- (--- (--- [--- [--- -- doesNotIntersect :: UpperBound -> LowerBound -> Bool doesNotIntersect NoUpperBound _ = False doesNotIntersect (UpperBound u ub) (LowerBound l lb) = u < l || (u == l && not (ub == InclusiveBound && lb == InclusiveBound)) -- | Test if a version falls within the version intervals. -- -- It exists mostly for completeness and testing. It satisfies the following -- properties: -- -- > withinIntervals v (toVersionIntervals vr) = withinRange v vr -- > withinIntervals v ivs = withinRange v (fromVersionIntervals ivs) -- withinIntervals :: Version -> VersionIntervals -> Bool withinIntervals v (VersionIntervals intervals) = any withinInterval intervals where withinInterval (lowerBound, upperBound) = withinLower lowerBound && withinUpper upperBound withinLower (LowerBound v' ExclusiveBound) = v' < v withinLower (LowerBound v' InclusiveBound) = v' <= v withinUpper NoUpperBound = True withinUpper (UpperBound v' ExclusiveBound) = v' > v withinUpper (UpperBound v' InclusiveBound) = v' >= v -- | Convert a 'VersionRange' to a sequence of version intervals. -- toVersionIntervals :: VersionRange -> VersionIntervals toVersionIntervals = foldVersionRange ( chkIvl (minLowerBound, NoUpperBound)) (\v -> chkIvl (LowerBound v InclusiveBound, UpperBound v InclusiveBound)) (\v -> chkIvl (LowerBound v ExclusiveBound, NoUpperBound)) (\v -> if isVersion0 v then VersionIntervals [] else chkIvl (minLowerBound, UpperBound v ExclusiveBound)) unionVersionIntervals intersectVersionIntervals where chkIvl interval = checkInvariant (VersionIntervals [interval]) -- | Convert a 'VersionIntervals' value back into a 'VersionRange' expression -- representing the version intervals. -- fromVersionIntervals :: VersionIntervals -> VersionRange fromVersionIntervals (VersionIntervals []) = noVersion fromVersionIntervals (VersionIntervals intervals) = foldr1 UnionVersionRanges [ interval l u | (l, u) <- intervals ] where interval (LowerBound v InclusiveBound) (UpperBound v' InclusiveBound) | v == v' = ThisVersion v interval (LowerBound v InclusiveBound) (UpperBound v' ExclusiveBound) | isWildcardRange v v' = WildcardVersion v interval l u = lowerBound l `intersectVersionRanges'` upperBound u lowerBound (LowerBound v InclusiveBound) | isVersion0 v = AnyVersion | otherwise = orLaterVersion v lowerBound (LowerBound v ExclusiveBound) = LaterVersion v upperBound NoUpperBound = AnyVersion upperBound (UpperBound v InclusiveBound) = orEarlierVersion v upperBound (UpperBound v ExclusiveBound) = EarlierVersion v intersectVersionRanges' vr AnyVersion = vr intersectVersionRanges' AnyVersion vr = vr intersectVersionRanges' vr vr' = IntersectVersionRanges vr vr' unionVersionIntervals :: VersionIntervals -> VersionIntervals -> VersionIntervals unionVersionIntervals (VersionIntervals is0) (VersionIntervals is'0) = checkInvariant (VersionIntervals (union is0 is'0)) where union is [] = is union [] is' = is' union (i:is) (i':is') = case unionInterval i i' of Left Nothing -> i : union is (i' :is') Left (Just i'') -> union is (i'':is') Right Nothing -> i' : union (i :is) is' Right (Just i'') -> union (i'':is) is' unionInterval :: VersionInterval -> VersionInterval -> Either (Maybe VersionInterval) (Maybe VersionInterval) unionInterval (lower , upper ) (lower', upper') -- Non-intersecting intervals with the left interval ending first | upper `doesNotTouch` lower' = Left Nothing -- Non-intersecting intervals with the right interval first | upper' `doesNotTouch` lower = Right Nothing -- Complete or partial overlap, with the left interval ending first | upper <= upper' = lowerBound `seq` Left (Just (lowerBound, upper')) -- Complete or partial overlap, with the left interval ending first | otherwise = lowerBound `seq` Right (Just (lowerBound, upper)) where lowerBound = min lower lower' intersectVersionIntervals :: VersionIntervals -> VersionIntervals -> VersionIntervals intersectVersionIntervals (VersionIntervals is0) (VersionIntervals is'0) = checkInvariant (VersionIntervals (intersect is0 is'0)) where intersect _ [] = [] intersect [] _ = [] intersect (i:is) (i':is') = case intersectInterval i i' of Left Nothing -> intersect is (i':is') Left (Just i'') -> i'' : intersect is (i':is') Right Nothing -> intersect (i:is) is' Right (Just i'') -> i'' : intersect (i:is) is' intersectInterval :: VersionInterval -> VersionInterval -> Either (Maybe VersionInterval) (Maybe VersionInterval) intersectInterval (lower , upper ) (lower', upper') -- Non-intersecting intervals with the left interval ending first | upper `doesNotIntersect` lower' = Left Nothing -- Non-intersecting intervals with the right interval first | upper' `doesNotIntersect` lower = Right Nothing -- Complete or partial overlap, with the left interval ending first | upper <= upper' = lowerBound `seq` Left (Just (lowerBound, upper)) -- Complete or partial overlap, with the right interval ending first | otherwise = lowerBound `seq` Right (Just (lowerBound, upper')) where lowerBound = max lower lower' ------------------------------- -- Parsing and pretty printing -- instance Text VersionRange where disp = fst . foldVersionRange' -- precedence: ( Disp.text "-any" , 0 :: Int) (\v -> (Disp.text "==" <> disp v , 0)) (\v -> (Disp.char '>' <> disp v , 0)) (\v -> (Disp.char '<' <> disp v , 0)) (\v -> (Disp.text ">=" <> disp v , 0)) (\v -> (Disp.text "<=" <> disp v , 0)) (\v _ -> (Disp.text "==" <> dispWild v , 0)) (\(r1, p1) (r2, p2) -> (punct 2 p1 r1 <+> Disp.text "||" <+> punct 2 p2 r2 , 2)) (\(r1, p1) (r2, p2) -> (punct 1 p1 r1 <+> Disp.text "&&" <+> punct 1 p2 r2 , 1)) (\(r, p) -> (Disp.parens r, p)) where dispWild (Version b _) = Disp.hcat (Disp.punctuate (Disp.char '.') (map Disp.int b)) <> Disp.text ".*" punct p p' | p < p' = Disp.parens | otherwise = id parse = expr where expr = do Parse.skipSpaces t <- term Parse.skipSpaces (do _ <- Parse.string "||" Parse.skipSpaces e <- expr return (UnionVersionRanges t e) +++ return t) term = do f <- factor Parse.skipSpaces (do _ <- Parse.string "&&" Parse.skipSpaces t <- term return (IntersectVersionRanges f t) +++ return f) factor = Parse.choice $ parens expr : parseAnyVersion : parseNoVersion : parseWildcardRange : map parseRangeOp rangeOps parseAnyVersion = Parse.string "-any" >> return AnyVersion parseNoVersion = Parse.string "-none" >> return noVersion parseWildcardRange = do _ <- Parse.string "==" Parse.skipSpaces branch <- Parse.sepBy1 digits (Parse.char '.') _ <- Parse.char '.' _ <- Parse.char '*' return (WildcardVersion (Version branch [])) parens p = Parse.between (Parse.char '(' >> Parse.skipSpaces) (Parse.char ')' >> Parse.skipSpaces) (do a <- p Parse.skipSpaces return (VersionRangeParens a)) digits = do first <- Parse.satisfy Char.isDigit if first == '0' then return 0 else do rest <- Parse.munch Char.isDigit return (read (first : rest)) parseRangeOp (s,f) = Parse.string s >> Parse.skipSpaces >> fmap f parse rangeOps = [ ("<", EarlierVersion), ("<=", orEarlierVersion), (">", LaterVersion), (">=", orLaterVersion), ("==", ThisVersion) ] Cabal-1.22.5.0/Distribution/Compat/0000755000000000000000000000000012627136220015032 5ustar0000000000000000Cabal-1.22.5.0/Distribution/Compat/Binary.hs0000644000000000000000000000224412627136220016614 0ustar0000000000000000{-# LANGUAGE CPP #-} #ifndef MIN_VERSION_binary #define MIN_VERSION_binary(x, y, z) 0 #endif module Distribution.Compat.Binary ( decodeOrFailIO #if __GLASGOW_HASKELL__ >= 708 || MIN_VERSION_binary(0,7,0) , module Data.Binary #else , Binary(..) , decode, encode #endif ) where import Control.Exception (ErrorCall(..), catch, evaluate) import Data.ByteString.Lazy (ByteString) #if __GLASGOW_HASKELL__ < 706 import Prelude hiding (catch) #endif #if __GLASGOW_HASKELL__ >= 708 || MIN_VERSION_binary(0,7,0) import Data.Binary #else import Data.Binary.Get import Data.Binary.Put import Distribution.Compat.Binary.Class import Distribution.Compat.Binary.Generic () -- | Decode a value from a lazy ByteString, reconstructing the original structure. -- decode :: Binary a => ByteString -> a decode = runGet get -- | Encode a value using binary serialisation to a lazy ByteString. -- encode :: Binary a => a -> ByteString encode = runPut . put {-# INLINE encode #-} #endif decodeOrFailIO :: Binary a => ByteString -> IO (Either String a) decodeOrFailIO bs = catch (evaluate (decode bs) >>= return . Right) $ \(ErrorCall str) -> return $ Left str Cabal-1.22.5.0/Distribution/Compat/CopyFile.hs0000644000000000000000000000726012627136220017105 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# OPTIONS_HADDOCK hide #-} module Distribution.Compat.CopyFile ( copyFile, copyFileChanged, filesEqual, copyOrdinaryFile, copyExecutableFile, setFileOrdinary, setFileExecutable, setDirOrdinary, ) where import Control.Monad ( when, unless ) import Control.Exception ( bracket, bracketOnError, throwIO ) import qualified Data.ByteString.Lazy as BSL import Distribution.Compat.Exception ( catchIO ) import System.IO.Error ( ioeSetLocation ) import System.Directory ( doesFileExist, renameFile, removeFile ) import Distribution.Compat.TempFile ( openBinaryTempFile ) import System.FilePath ( takeDirectory ) import System.IO ( openBinaryFile, IOMode(ReadMode), hClose, hGetBuf, hPutBuf , withBinaryFile ) import Foreign ( allocaBytes ) #ifndef mingw32_HOST_OS import System.Posix.Internals (withFilePath) import System.Posix.Types ( FileMode ) import System.Posix.Internals ( c_chmod ) import Foreign.C ( throwErrnoPathIfMinus1_ ) #endif /* mingw32_HOST_OS */ copyOrdinaryFile, copyExecutableFile :: FilePath -> FilePath -> IO () copyOrdinaryFile src dest = copyFile src dest >> setFileOrdinary dest copyExecutableFile src dest = copyFile src dest >> setFileExecutable dest setFileOrdinary, setFileExecutable, setDirOrdinary :: FilePath -> IO () #ifndef mingw32_HOST_OS setFileOrdinary path = setFileMode path 0o644 -- file perms -rw-r--r-- setFileExecutable path = setFileMode path 0o755 -- file perms -rwxr-xr-x setFileMode :: FilePath -> FileMode -> IO () setFileMode name m = withFilePath name $ \s -> do throwErrnoPathIfMinus1_ "setFileMode" name (c_chmod s m) #else setFileOrdinary _ = return () setFileExecutable _ = return () #endif -- This happens to be true on Unix and currently on Windows too: setDirOrdinary = setFileExecutable -- | Copies a file to a new destination. -- Often you should use `copyFileChanged` instead. copyFile :: FilePath -> FilePath -> IO () copyFile fromFPath toFPath = copy `catchIO` (\ioe -> throwIO (ioeSetLocation ioe "copyFile")) where copy = bracket (openBinaryFile fromFPath ReadMode) hClose $ \hFrom -> bracketOnError openTmp cleanTmp $ \(tmpFPath, hTmp) -> do allocaBytes bufferSize $ copyContents hFrom hTmp hClose hTmp renameFile tmpFPath toFPath openTmp = openBinaryTempFile (takeDirectory toFPath) ".copyFile.tmp" cleanTmp (tmpFPath, hTmp) = do hClose hTmp `catchIO` \_ -> return () removeFile tmpFPath `catchIO` \_ -> return () bufferSize = 4096 copyContents hFrom hTo buffer = do count <- hGetBuf hFrom buffer bufferSize when (count > 0) $ do hPutBuf hTo buffer count copyContents hFrom hTo buffer -- | Like `copyFile`, but does not touch the target if source and destination -- are already byte-identical. This is recommended as it is useful for -- time-stamp based recompilation avoidance. copyFileChanged :: FilePath -> FilePath -> IO () copyFileChanged src dest = do equal <- filesEqual src dest unless equal $ copyFile src dest -- | Checks if two files are byte-identical. -- Returns False if either of the files do not exist. filesEqual :: FilePath -> FilePath -> IO Bool filesEqual f1 f2 = do ex1 <- doesFileExist f1 ex2 <- doesFileExist f2 if not (ex1 && ex2) then return False else do withBinaryFile f1 ReadMode $ \h1 -> withBinaryFile f2 ReadMode $ \h2 -> do c1 <- BSL.hGetContents h1 c2 <- BSL.hGetContents h2 return $! c1 == c2 Cabal-1.22.5.0/Distribution/Compat/CreatePipe.hs0000644000000000000000000000404712627136220017414 0ustar0000000000000000{-# LANGUAGE CPP, ForeignFunctionInterface #-} module Distribution.Compat.CreatePipe (createPipe) where import System.IO (Handle, hSetEncoding, localeEncoding) -- The mingw32_HOST_OS CPP macro is GHC-specific #if mingw32_HOST_OS import Control.Exception (onException) import Foreign.C.Error (throwErrnoIfMinus1_) import Foreign.C.Types (CInt(..), CUInt(..)) import Foreign.Ptr (Ptr) import Foreign.Marshal.Array (allocaArray) import Foreign.Storable (peek, peekElemOff) import GHC.IO.FD (mkFD) import GHC.IO.Device (IODeviceType(Stream)) import GHC.IO.Handle.FD (mkHandleFromFD) import System.IO (IOMode(ReadMode, WriteMode)) #elif ghcjs_HOST_OS #else import System.Posix.IO (fdToHandle) import qualified System.Posix.IO as Posix #endif createPipe :: IO (Handle, Handle) -- The mingw32_HOST_OS CPP macro is GHC-specific #if mingw32_HOST_OS createPipe = do (readfd, writefd) <- allocaArray 2 $ \ pfds -> do throwErrnoIfMinus1_ "_pipe" $ c__pipe pfds 2 ({- _O_BINARY -} 32768) readfd <- peek pfds writefd <- peekElemOff pfds 1 return (readfd, writefd) (do readh <- fdToHandle readfd ReadMode writeh <- fdToHandle writefd WriteMode hSetEncoding readh localeEncoding hSetEncoding writeh localeEncoding return (readh, writeh)) `onException` (close readfd >> close writefd) where fdToHandle :: CInt -> IOMode -> IO Handle fdToHandle fd mode = do (fd', deviceType) <- mkFD fd mode (Just (Stream, 0, 0)) False False mkHandleFromFD fd' deviceType "" mode False Nothing close :: CInt -> IO () close = throwErrnoIfMinus1_ "_close" . c__close foreign import ccall "io.h _pipe" c__pipe :: Ptr CInt -> CUInt -> CInt -> IO CInt foreign import ccall "io.h _close" c__close :: CInt -> IO CInt #elif ghcjs_HOST_OS createPipe = error "createPipe" #else createPipe = do (readfd, writefd) <- Posix.createPipe readh <- fdToHandle readfd writeh <- fdToHandle writefd hSetEncoding readh localeEncoding hSetEncoding writeh localeEncoding return (readh, writeh) #endif Cabal-1.22.5.0/Distribution/Compat/Environment.hs0000644000000000000000000000124312627136220017672 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# OPTIONS_HADDOCK hide #-} module Distribution.Compat.Environment (getEnvironment) where import qualified System.Environment as System #ifdef mingw32_HOST_OS import qualified Data.Char as Char (toUpper) #endif getEnvironment :: IO [(String, String)] #ifdef mingw32_HOST_OS -- On Windows, the names of environment variables are case-insensitive, but are -- often given in mixed-case (e.g. "PATH" is "Path"), so we have to normalise -- them. getEnvironment = fmap upcaseVars System.getEnvironment where upcaseVars = map upcaseVar upcaseVar (var, val) = (map Char.toUpper var, val) #else getEnvironment = System.getEnvironment #endif Cabal-1.22.5.0/Distribution/Compat/Exception.hs0000644000000000000000000000060512627136220017325 0ustar0000000000000000module Distribution.Compat.Exception ( catchIO, catchExit, tryIO, ) where import System.Exit import qualified Control.Exception as Exception tryIO :: IO a -> IO (Either Exception.IOException a) tryIO = Exception.try catchIO :: IO a -> (Exception.IOException -> IO a) -> IO a catchIO = Exception.catch catchExit :: IO a -> (ExitCode -> IO a) -> IO a catchExit = Exception.catch Cabal-1.22.5.0/Distribution/Compat/ReadP.hs0000644000000000000000000003251512627136220016367 0ustar0000000000000000{-# LANGUAGE CPP #-} ----------------------------------------------------------------------------- -- | -- Module : Distribution.Compat.ReadP -- Copyright : (c) The University of Glasgow 2002 -- License : BSD-style (see the file libraries/base/LICENSE) -- -- Maintainer : libraries@haskell.org -- Portability : portable -- -- This is a library of parser combinators, originally written by Koen Claessen. -- It parses all alternatives in parallel, so it never keeps hold of -- the beginning of the input string, a common source of space leaks with -- other parsers. The '(+++)' choice combinator is genuinely commutative; -- it makes no difference which branch is \"shorter\". -- -- See also Koen's paper /Parallel Parsing Processes/ -- (). -- -- This version of ReadP has been locally hacked to make it H98, by -- Martin Sjögren -- -- The unit tests have been moved to UnitTest.Distribution.Compat.ReadP, by -- Mark Lentczner ----------------------------------------------------------------------------- module Distribution.Compat.ReadP ( -- * The 'ReadP' type ReadP, -- :: * -> *; instance Functor, Monad, MonadPlus -- * Primitive operations get, -- :: ReadP Char look, -- :: ReadP String (+++), -- :: ReadP a -> ReadP a -> ReadP a (<++), -- :: ReadP a -> ReadP a -> ReadP a gather, -- :: ReadP a -> ReadP (String, a) -- * Other operations pfail, -- :: ReadP a satisfy, -- :: (Char -> Bool) -> ReadP Char char, -- :: Char -> ReadP Char string, -- :: String -> ReadP String munch, -- :: (Char -> Bool) -> ReadP String munch1, -- :: (Char -> Bool) -> ReadP String skipSpaces, -- :: ReadP () choice, -- :: [ReadP a] -> ReadP a count, -- :: Int -> ReadP a -> ReadP [a] between, -- :: ReadP open -> ReadP close -> ReadP a -> ReadP a option, -- :: a -> ReadP a -> ReadP a optional, -- :: ReadP a -> ReadP () many, -- :: ReadP a -> ReadP [a] many1, -- :: ReadP a -> ReadP [a] skipMany, -- :: ReadP a -> ReadP () skipMany1, -- :: ReadP a -> ReadP () sepBy, -- :: ReadP a -> ReadP sep -> ReadP [a] sepBy1, -- :: ReadP a -> ReadP sep -> ReadP [a] endBy, -- :: ReadP a -> ReadP sep -> ReadP [a] endBy1, -- :: ReadP a -> ReadP sep -> ReadP [a] chainr, -- :: ReadP a -> ReadP (a -> a -> a) -> a -> ReadP a chainl, -- :: ReadP a -> ReadP (a -> a -> a) -> a -> ReadP a chainl1, -- :: ReadP a -> ReadP (a -> a -> a) -> ReadP a chainr1, -- :: ReadP a -> ReadP (a -> a -> a) -> ReadP a manyTill, -- :: ReadP a -> ReadP end -> ReadP [a] -- * Running a parser ReadS, -- :: *; = String -> [(a,String)] readP_to_S, -- :: ReadP a -> ReadS a readS_to_P -- :: ReadS a -> ReadP a ) where import Control.Monad( MonadPlus(..), liftM, liftM2, ap ) import Data.Char (isSpace) #if __GLASGOW_HASKELL__ < 710 import Control.Applicative (Applicative(..)) #endif import Control.Applicative (Alternative(empty, (<|>))) infixr 5 +++, <++ -- --------------------------------------------------------------------------- -- The P type -- is representation type -- should be kept abstract data P s a = Get (s -> P s a) | Look ([s] -> P s a) | Fail | Result a (P s a) | Final [(a,[s])] -- invariant: list is non-empty! -- Monad, MonadPlus instance Functor (P s) where fmap = liftM instance Applicative (P s) where pure = return (<*>) = ap instance Monad (P s) where return x = Result x Fail (Get f) >>= k = Get (\c -> f c >>= k) (Look f) >>= k = Look (\s -> f s >>= k) Fail >>= _ = Fail (Result x p) >>= k = k x `mplus` (p >>= k) (Final r) >>= k = final [ys' | (x,s) <- r, ys' <- run (k x) s] fail _ = Fail instance Alternative (P s) where empty = mzero (<|>) = mplus instance MonadPlus (P s) where mzero = Fail -- most common case: two gets are combined Get f1 `mplus` Get f2 = Get (\c -> f1 c `mplus` f2 c) -- results are delivered as soon as possible Result x p `mplus` q = Result x (p `mplus` q) p `mplus` Result x q = Result x (p `mplus` q) -- fail disappears Fail `mplus` p = p p `mplus` Fail = p -- two finals are combined -- final + look becomes one look and one final (=optimization) -- final + sthg else becomes one look and one final Final r `mplus` Final t = Final (r ++ t) Final r `mplus` Look f = Look (\s -> Final (r ++ run (f s) s)) Final r `mplus` p = Look (\s -> Final (r ++ run p s)) Look f `mplus` Final r = Look (\s -> Final (run (f s) s ++ r)) p `mplus` Final r = Look (\s -> Final (run p s ++ r)) -- two looks are combined (=optimization) -- look + sthg else floats upwards Look f `mplus` Look g = Look (\s -> f s `mplus` g s) Look f `mplus` p = Look (\s -> f s `mplus` p) p `mplus` Look f = Look (\s -> p `mplus` f s) -- --------------------------------------------------------------------------- -- The ReadP type newtype Parser r s a = R ((a -> P s r) -> P s r) type ReadP r a = Parser r Char a -- Functor, Monad, MonadPlus instance Functor (Parser r s) where fmap h (R f) = R (\k -> f (k . h)) instance Applicative (Parser r s) where pure = return (<*>) = ap instance Monad (Parser r s) where return x = R (\k -> k x) fail _ = R (\_ -> Fail) R m >>= f = R (\k -> m (\a -> let R m' = f a in m' k)) --instance MonadPlus (Parser r s) where -- mzero = pfail -- mplus = (+++) -- --------------------------------------------------------------------------- -- Operations over P final :: [(a,[s])] -> P s a -- Maintains invariant for Final constructor final [] = Fail final r = Final r run :: P c a -> ([c] -> [(a, [c])]) run (Get f) (c:s) = run (f c) s run (Look f) s = run (f s) s run (Result x p) s = (x,s) : run p s run (Final r) _ = r run _ _ = [] -- --------------------------------------------------------------------------- -- Operations over ReadP get :: ReadP r Char -- ^ Consumes and returns the next character. -- Fails if there is no input left. get = R Get look :: ReadP r String -- ^ Look-ahead: returns the part of the input that is left, without -- consuming it. look = R Look pfail :: ReadP r a -- ^ Always fails. pfail = R (\_ -> Fail) (+++) :: ReadP r a -> ReadP r a -> ReadP r a -- ^ Symmetric choice. R f1 +++ R f2 = R (\k -> f1 k `mplus` f2 k) (<++) :: ReadP a a -> ReadP r a -> ReadP r a -- ^ Local, exclusive, left-biased choice: If left parser -- locally produces any result at all, then right parser is -- not used. R f <++ q = do s <- look probe (f return) s 0 where probe (Get f') (c:s) n = probe (f' c) s (n+1 :: Int) probe (Look f') s n = probe (f' s) s n probe p@(Result _ _) _ n = discard n >> R (p >>=) probe (Final r) _ _ = R (Final r >>=) probe _ _ _ = q discard 0 = return () discard n = get >> discard (n-1 :: Int) gather :: ReadP (String -> P Char r) a -> ReadP r (String, a) -- ^ Transforms a parser into one that does the same, but -- in addition returns the exact characters read. -- IMPORTANT NOTE: 'gather' gives a runtime error if its first argument -- is built using any occurrences of readS_to_P. gather (R m) = R (\k -> gath id (m (\a -> return (\s -> k (s,a))))) where gath l (Get f) = Get (\c -> gath (l.(c:)) (f c)) gath _ Fail = Fail gath l (Look f) = Look (\s -> gath l (f s)) gath l (Result k p) = k (l []) `mplus` gath l p gath _ (Final _) = error "do not use readS_to_P in gather!" -- --------------------------------------------------------------------------- -- Derived operations satisfy :: (Char -> Bool) -> ReadP r Char -- ^ Consumes and returns the next character, if it satisfies the -- specified predicate. satisfy p = do c <- get; if p c then return c else pfail char :: Char -> ReadP r Char -- ^ Parses and returns the specified character. char c = satisfy (c ==) string :: String -> ReadP r String -- ^ Parses and returns the specified string. string this = do s <- look; scan this s where scan [] _ = do return this scan (x:xs) (y:ys) | x == y = do get >> scan xs ys scan _ _ = do pfail munch :: (Char -> Bool) -> ReadP r String -- ^ Parses the first zero or more characters satisfying the predicate. munch p = do s <- look scan s where scan (c:cs) | p c = do _ <- get; s <- scan cs; return (c:s) scan _ = do return "" munch1 :: (Char -> Bool) -> ReadP r String -- ^ Parses the first one or more characters satisfying the predicate. munch1 p = do c <- get if p c then do s <- munch p; return (c:s) else pfail choice :: [ReadP r a] -> ReadP r a -- ^ Combines all parsers in the specified list. choice [] = pfail choice [p] = p choice (p:ps) = p +++ choice ps skipSpaces :: ReadP r () -- ^ Skips all whitespace. skipSpaces = do s <- look skip s where skip (c:s) | isSpace c = do _ <- get; skip s skip _ = do return () count :: Int -> ReadP r a -> ReadP r [a] -- ^ @ count n p @ parses @n@ occurrences of @p@ in sequence. A list of -- results is returned. count n p = sequence (replicate n p) between :: ReadP r open -> ReadP r close -> ReadP r a -> ReadP r a -- ^ @ between open close p @ parses @open@, followed by @p@ and finally -- @close@. Only the value of @p@ is returned. between open close p = do _ <- open x <- p _ <- close return x option :: a -> ReadP r a -> ReadP r a -- ^ @option x p@ will either parse @p@ or return @x@ without consuming -- any input. option x p = p +++ return x optional :: ReadP r a -> ReadP r () -- ^ @optional p@ optionally parses @p@ and always returns @()@. optional p = (p >> return ()) +++ return () many :: ReadP r a -> ReadP r [a] -- ^ Parses zero or more occurrences of the given parser. many p = return [] +++ many1 p many1 :: ReadP r a -> ReadP r [a] -- ^ Parses one or more occurrences of the given parser. many1 p = liftM2 (:) p (many p) skipMany :: ReadP r a -> ReadP r () -- ^ Like 'many', but discards the result. skipMany p = many p >> return () skipMany1 :: ReadP r a -> ReadP r () -- ^ Like 'many1', but discards the result. skipMany1 p = p >> skipMany p sepBy :: ReadP r a -> ReadP r sep -> ReadP r [a] -- ^ @sepBy p sep@ parses zero or more occurrences of @p@, separated by @sep@. -- Returns a list of values returned by @p@. sepBy p sep = sepBy1 p sep +++ return [] sepBy1 :: ReadP r a -> ReadP r sep -> ReadP r [a] -- ^ @sepBy1 p sep@ parses one or more occurrences of @p@, separated by @sep@. -- Returns a list of values returned by @p@. sepBy1 p sep = liftM2 (:) p (many (sep >> p)) endBy :: ReadP r a -> ReadP r sep -> ReadP r [a] -- ^ @endBy p sep@ parses zero or more occurrences of @p@, separated and ended -- by @sep@. endBy p sep = many (do x <- p ; _ <- sep ; return x) endBy1 :: ReadP r a -> ReadP r sep -> ReadP r [a] -- ^ @endBy p sep@ parses one or more occurrences of @p@, separated and ended -- by @sep@. endBy1 p sep = many1 (do x <- p ; _ <- sep ; return x) chainr :: ReadP r a -> ReadP r (a -> a -> a) -> a -> ReadP r a -- ^ @chainr p op x@ parses zero or more occurrences of @p@, separated by @op@. -- Returns a value produced by a /right/ associative application of all -- functions returned by @op@. If there are no occurrences of @p@, @x@ is -- returned. chainr p op x = chainr1 p op +++ return x chainl :: ReadP r a -> ReadP r (a -> a -> a) -> a -> ReadP r a -- ^ @chainl p op x@ parses zero or more occurrences of @p@, separated by @op@. -- Returns a value produced by a /left/ associative application of all -- functions returned by @op@. If there are no occurrences of @p@, @x@ is -- returned. chainl p op x = chainl1 p op +++ return x chainr1 :: ReadP r a -> ReadP r (a -> a -> a) -> ReadP r a -- ^ Like 'chainr', but parses one or more occurrences of @p@. chainr1 p op = scan where scan = p >>= rest rest x = do f <- op y <- scan return (f x y) +++ return x chainl1 :: ReadP r a -> ReadP r (a -> a -> a) -> ReadP r a -- ^ Like 'chainl', but parses one or more occurrences of @p@. chainl1 p op = p >>= rest where rest x = do f <- op y <- p rest (f x y) +++ return x manyTill :: ReadP r a -> ReadP [a] end -> ReadP r [a] -- ^ @manyTill p end@ parses zero or more occurrences of @p@, until @end@ -- succeeds. Returns a list of values returned by @p@. manyTill p end = scan where scan = (end >> return []) <++ (liftM2 (:) p scan) -- --------------------------------------------------------------------------- -- Converting between ReadP and Read readP_to_S :: ReadP a a -> ReadS a -- ^ Converts a parser into a Haskell ReadS-style function. -- This is the main way in which you can \"run\" a 'ReadP' parser: -- the expanded type is -- @ readP_to_S :: ReadP a -> String -> [(a,String)] @ readP_to_S (R f) = run (f return) readS_to_P :: ReadS a -> ReadP r a -- ^ Converts a Haskell ReadS-style function into a parser. -- Warning: This introduces local backtracking in the resulting -- parser, and therefore a possible inefficiency. readS_to_P r = R (\k -> Look (\s -> final [bs'' | (a,s') <- r s, bs'' <- run (k a) s'])) Cabal-1.22.5.0/Distribution/Compat/TempFile.hs0000644000000000000000000001105312627136220017073 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# OPTIONS_HADDOCK hide #-} module Distribution.Compat.TempFile ( openTempFile, openBinaryTempFile, openNewBinaryFile, createTempDirectory, ) where import System.FilePath (()) import Foreign.C (eEXIST) import System.IO (Handle, openTempFile, openBinaryTempFile) import Data.Bits ((.|.)) import System.Posix.Internals (c_open, c_close, o_CREAT, o_EXCL, o_RDWR, o_BINARY, o_NONBLOCK, o_NOCTTY) import System.IO.Error (isAlreadyExistsError) import System.Posix.Internals (withFilePath) import Foreign.C (CInt) import GHC.IO.Handle.FD (fdToHandle) import Distribution.Compat.Exception (tryIO) import Control.Exception (onException) import Foreign.C (getErrno, errnoToIOError) import System.Posix.Internals (c_getpid) #if defined(mingw32_HOST_OS) || defined(ghcjs_HOST_OS) import System.Directory ( createDirectory ) #else import qualified System.Posix #endif -- ------------------------------------------------------------ -- * temporary files -- ------------------------------------------------------------ -- This is here for Haskell implementations that do not come with -- System.IO.openTempFile. This includes nhc-1.20, hugs-2006.9. -- TODO: Not sure about JHC -- TODO: This file should probably be removed. -- This is a copy/paste of the openBinaryTempFile definition, but -- if uses 666 rather than 600 for the permissions. The base library -- needs to be changed to make this better. openNewBinaryFile :: FilePath -> String -> IO (FilePath, Handle) openNewBinaryFile dir template = do pid <- c_getpid findTempName pid where -- We split off the last extension, so we can use .foo.ext files -- for temporary files (hidden on Unix OSes). Unfortunately we're -- below file path in the hierarchy here. (prefix,suffix) = case break (== '.') $ reverse template of -- First case: template contains no '.'s. Just re-reverse it. (rev_suffix, "") -> (reverse rev_suffix, "") -- Second case: template contains at least one '.'. Strip the -- dot from the prefix and prepend it to the suffix (if we don't -- do this, the unique number will get added after the '.' and -- thus be part of the extension, which is wrong.) (rev_suffix, '.':rest) -> (reverse rest, '.':reverse rev_suffix) -- Otherwise, something is wrong, because (break (== '.')) should -- always return a pair with either the empty string or a string -- beginning with '.' as the second component. _ -> error "bug in System.IO.openTempFile" oflags = rw_flags .|. o_EXCL .|. o_BINARY findTempName x = do fd <- withFilePath filepath $ \ f -> c_open f oflags 0o666 if fd < 0 then do errno <- getErrno if errno == eEXIST then findTempName (x+1) else ioError (errnoToIOError "openNewBinaryFile" errno Nothing (Just dir)) else do -- TODO: We want to tell fdToHandle what the file path is, -- as any exceptions etc will only be able to report the -- FD currently h <- fdToHandle fd `onException` c_close fd return (filepath, h) where filename = prefix ++ show x ++ suffix filepath = dir `combine` filename -- FIXME: bits copied from System.FilePath combine a b | null b = a | null a = b | last a == pathSeparator = a ++ b | otherwise = a ++ [pathSeparator] ++ b -- FIXME: Should use System.FilePath library pathSeparator :: Char #ifdef mingw32_HOST_OS pathSeparator = '\\' #else pathSeparator = '/' #endif -- FIXME: Copied from GHC.Handle std_flags, output_flags, rw_flags :: CInt std_flags = o_NONBLOCK .|. o_NOCTTY output_flags = std_flags .|. o_CREAT rw_flags = output_flags .|. o_RDWR createTempDirectory :: FilePath -> String -> IO FilePath createTempDirectory dir template = do pid <- c_getpid findTempName pid where findTempName x = do let dirpath = dir template ++ "-" ++ show x r <- tryIO $ mkPrivateDir dirpath case r of Right _ -> return dirpath Left e | isAlreadyExistsError e -> findTempName (x+1) | otherwise -> ioError e mkPrivateDir :: String -> IO () #if defined(mingw32_HOST_OS) || defined(ghcjs_HOST_OS) mkPrivateDir s = createDirectory s #else mkPrivateDir s = System.Posix.createDirectory s 0o700 #endif Cabal-1.22.5.0/Distribution/Compat/Binary/0000755000000000000000000000000012627136220016256 5ustar0000000000000000Cabal-1.22.5.0/Distribution/Compat/Binary/Class.hs0000644000000000000000000004220212627136220017657 0ustar0000000000000000{-# LANGUAGE CPP, FlexibleContexts #-} {-# LANGUAGE Trustworthy #-} {-# LANGUAGE DefaultSignatures #-} ----------------------------------------------------------------------------- -- | -- Module : Distribution.Compat.Binary.Class -- Copyright : Lennart Kolmodin -- License : BSD3-style (see LICENSE) -- -- Maintainer : Lennart Kolmodin -- Stability : unstable -- Portability : portable to Hugs and GHC. Requires the FFI and some flexible instances -- -- Typeclass and instances for binary serialization. -- ----------------------------------------------------------------------------- module Distribution.Compat.Binary.Class ( -- * The Binary class Binary(..) -- * Support for generics , GBinary(..) ) where import Data.Word import Data.Binary.Put import Data.Binary.Get import Control.Monad import Foreign import Data.ByteString.Lazy (ByteString) import qualified Data.ByteString.Lazy as L import Data.Char (chr,ord) import Data.List (unfoldr) -- And needed for the instances: import qualified Data.ByteString as B import qualified Data.Map as Map import qualified Data.Set as Set import qualified Data.IntMap as IntMap import qualified Data.IntSet as IntSet import qualified Data.Ratio as R import qualified Data.Tree as T import Data.Array.Unboxed import GHC.Generics -- -- This isn't available in older Hugs or older GHC -- #if __GLASGOW_HASKELL__ >= 606 import qualified Data.Sequence as Seq import qualified Data.Foldable as Fold #endif ------------------------------------------------------------------------ class GBinary f where gput :: f t -> Put gget :: Get (f t) -- | The 'Binary' class provides 'put' and 'get', methods to encode and -- decode a Haskell value to a lazy 'ByteString'. It mirrors the 'Read' and -- 'Show' classes for textual representation of Haskell types, and is -- suitable for serialising Haskell values to disk, over the network. -- -- For decoding and generating simple external binary formats (e.g. C -- structures), Binary may be used, but in general is not suitable -- for complex protocols. Instead use the 'Put' and 'Get' primitives -- directly. -- -- Instances of Binary should satisfy the following property: -- -- > decode . encode == id -- -- That is, the 'get' and 'put' methods should be the inverse of each -- other. A range of instances are provided for basic Haskell types. -- class Binary t where -- | Encode a value in the Put monad. put :: t -> Put -- | Decode a value in the Get monad get :: Get t default put :: (Generic t, GBinary (Rep t)) => t -> Put put = gput . from default get :: (Generic t, GBinary (Rep t)) => Get t get = to `fmap` gget ------------------------------------------------------------------------ -- Simple instances -- The () type need never be written to disk: values of singleton type -- can be reconstructed from the type alone instance Binary () where put () = return () get = return () -- Bools are encoded as a byte in the range 0 .. 1 instance Binary Bool where put = putWord8 . fromIntegral . fromEnum get = liftM (toEnum . fromIntegral) getWord8 -- Values of type 'Ordering' are encoded as a byte in the range 0 .. 2 instance Binary Ordering where put = putWord8 . fromIntegral . fromEnum get = liftM (toEnum . fromIntegral) getWord8 ------------------------------------------------------------------------ -- Words and Ints -- Words8s are written as bytes instance Binary Word8 where put = putWord8 get = getWord8 -- Words16s are written as 2 bytes in big-endian (network) order instance Binary Word16 where put = putWord16be get = getWord16be -- Words32s are written as 4 bytes in big-endian (network) order instance Binary Word32 where put = putWord32be get = getWord32be -- Words64s are written as 8 bytes in big-endian (network) order instance Binary Word64 where put = putWord64be get = getWord64be -- Int8s are written as a single byte. instance Binary Int8 where put i = put (fromIntegral i :: Word8) get = liftM fromIntegral (get :: Get Word8) -- Int16s are written as a 2 bytes in big endian format instance Binary Int16 where put i = put (fromIntegral i :: Word16) get = liftM fromIntegral (get :: Get Word16) -- Int32s are written as a 4 bytes in big endian format instance Binary Int32 where put i = put (fromIntegral i :: Word32) get = liftM fromIntegral (get :: Get Word32) -- Int64s are written as a 4 bytes in big endian format instance Binary Int64 where put i = put (fromIntegral i :: Word64) get = liftM fromIntegral (get :: Get Word64) ------------------------------------------------------------------------ -- Words are are written as Word64s, that is, 8 bytes in big endian format instance Binary Word where put i = put (fromIntegral i :: Word64) get = liftM fromIntegral (get :: Get Word64) -- Ints are are written as Int64s, that is, 8 bytes in big endian format instance Binary Int where put i = put (fromIntegral i :: Int64) get = liftM fromIntegral (get :: Get Int64) ------------------------------------------------------------------------ -- -- Portable, and pretty efficient, serialisation of Integer -- -- Fixed-size type for a subset of Integer type SmallInt = Int32 -- Integers are encoded in two ways: if they fit inside a SmallInt, -- they're written as a byte tag, and that value. If the Integer value -- is too large to fit in a SmallInt, it is written as a byte array, -- along with a sign and length field. instance Binary Integer where {-# INLINE put #-} put n | n >= lo && n <= hi = do putWord8 0 put (fromIntegral n :: SmallInt) -- fast path where lo = fromIntegral (minBound :: SmallInt) :: Integer hi = fromIntegral (maxBound :: SmallInt) :: Integer put n = do putWord8 1 put sign put (unroll (abs n)) -- unroll the bytes where sign = fromIntegral (signum n) :: Word8 {-# INLINE get #-} get = do tag <- get :: Get Word8 case tag of 0 -> liftM fromIntegral (get :: Get SmallInt) _ -> do sign <- get bytes <- get let v = roll bytes return $! if sign == (1 :: Word8) then v else - v -- -- Fold and unfold an Integer to and from a list of its bytes -- unroll :: Integer -> [Word8] unroll = unfoldr step where step 0 = Nothing step i = Just (fromIntegral i, i `shiftR` 8) roll :: [Word8] -> Integer roll = foldr unstep 0 where unstep b a = a `shiftL` 8 .|. fromIntegral b {- -- -- An efficient, raw serialisation for Integer (GHC only) -- -- TODO This instance is not architecture portable. GMP stores numbers as -- arrays of machine sized words, so the byte format is not portable across -- architectures with different endianness and word size. import Data.ByteString.Base (toForeignPtr,unsafePackAddress, memcpy) import GHC.Base hiding (ord, chr) import GHC.Prim import GHC.Ptr (Ptr(..)) import GHC.IOBase (IO(..)) instance Binary Integer where put (S# i) = putWord8 0 >> put (I# i) put (J# s ba) = do putWord8 1 put (I# s) put (BA ba) get = do b <- getWord8 case b of 0 -> do (I# i#) <- get return (S# i#) _ -> do (I# s#) <- get (BA a#) <- get return (J# s# a#) instance Binary ByteArray where -- Pretty safe. put (BA ba) = let sz = sizeofByteArray# ba -- (primitive) in *bytes* addr = byteArrayContents# ba bs = unsafePackAddress (I# sz) addr in put bs -- write as a ByteString. easy, yay! -- Pretty scary. Should be quick though get = do (fp, off, n@(I# sz)) <- liftM toForeignPtr get -- so decode a ByteString assert (off == 0) $ return $ unsafePerformIO $ do (MBA arr) <- newByteArray sz -- and copy it into a ByteArray# let to = byteArrayContents# (unsafeCoerce# arr) -- urk, is this safe? withForeignPtr fp $ \from -> memcpy (Ptr to) from (fromIntegral n) freezeByteArray arr -- wrapper for ByteArray# data ByteArray = BA {-# UNPACK #-} !ByteArray# data MBA = MBA {-# UNPACK #-} !(MutableByteArray# RealWorld) newByteArray :: Int# -> IO MBA newByteArray sz = IO $ \s -> case newPinnedByteArray# sz s of { (# s', arr #) -> (# s', MBA arr #) } freezeByteArray :: MutableByteArray# RealWorld -> IO ByteArray freezeByteArray arr = IO $ \s -> case unsafeFreezeByteArray# arr s of { (# s', arr' #) -> (# s', BA arr' #) } -} instance (Binary a,Integral a) => Binary (R.Ratio a) where put r = put (R.numerator r) >> put (R.denominator r) get = liftM2 (R.%) get get ------------------------------------------------------------------------ -- Char is serialised as UTF-8 instance Binary Char where put a | c <= 0x7f = put (fromIntegral c :: Word8) | c <= 0x7ff = do put (0xc0 .|. y) put (0x80 .|. z) | c <= 0xffff = do put (0xe0 .|. x) put (0x80 .|. y) put (0x80 .|. z) | c <= 0x10ffff = do put (0xf0 .|. w) put (0x80 .|. x) put (0x80 .|. y) put (0x80 .|. z) | otherwise = error "Not a valid Unicode code point" where c = ord a z, y, x, w :: Word8 z = fromIntegral (c .&. 0x3f) y = fromIntegral (shiftR c 6 .&. 0x3f) x = fromIntegral (shiftR c 12 .&. 0x3f) w = fromIntegral (shiftR c 18 .&. 0x7) get = do let getByte = liftM (fromIntegral :: Word8 -> Int) get shiftL6 = flip shiftL 6 :: Int -> Int w <- getByte r <- case () of _ | w < 0x80 -> return w | w < 0xe0 -> do x <- liftM (xor 0x80) getByte return (x .|. shiftL6 (xor 0xc0 w)) | w < 0xf0 -> do x <- liftM (xor 0x80) getByte y <- liftM (xor 0x80) getByte return (y .|. shiftL6 (x .|. shiftL6 (xor 0xe0 w))) | otherwise -> do x <- liftM (xor 0x80) getByte y <- liftM (xor 0x80) getByte z <- liftM (xor 0x80) getByte return (z .|. shiftL6 (y .|. shiftL6 (x .|. shiftL6 (xor 0xf0 w)))) return $! chr r ------------------------------------------------------------------------ -- Instances for the first few tuples instance (Binary a, Binary b) => Binary (a,b) where put (a,b) = put a >> put b get = liftM2 (,) get get instance (Binary a, Binary b, Binary c) => Binary (a,b,c) where put (a,b,c) = put a >> put b >> put c get = liftM3 (,,) get get get instance (Binary a, Binary b, Binary c, Binary d) => Binary (a,b,c,d) where put (a,b,c,d) = put a >> put b >> put c >> put d get = liftM4 (,,,) get get get get instance (Binary a, Binary b, Binary c, Binary d, Binary e) => Binary (a,b,c,d,e) where put (a,b,c,d,e) = put a >> put b >> put c >> put d >> put e get = liftM5 (,,,,) get get get get get -- -- and now just recurse: -- instance (Binary a, Binary b, Binary c, Binary d, Binary e, Binary f) => Binary (a,b,c,d,e,f) where put (a,b,c,d,e,f) = put (a,(b,c,d,e,f)) get = do (a,(b,c,d,e,f)) <- get ; return (a,b,c,d,e,f) instance (Binary a, Binary b, Binary c, Binary d, Binary e, Binary f, Binary g) => Binary (a,b,c,d,e,f,g) where put (a,b,c,d,e,f,g) = put (a,(b,c,d,e,f,g)) get = do (a,(b,c,d,e,f,g)) <- get ; return (a,b,c,d,e,f,g) instance (Binary a, Binary b, Binary c, Binary d, Binary e, Binary f, Binary g, Binary h) => Binary (a,b,c,d,e,f,g,h) where put (a,b,c,d,e,f,g,h) = put (a,(b,c,d,e,f,g,h)) get = do (a,(b,c,d,e,f,g,h)) <- get ; return (a,b,c,d,e,f,g,h) instance (Binary a, Binary b, Binary c, Binary d, Binary e, Binary f, Binary g, Binary h, Binary i) => Binary (a,b,c,d,e,f,g,h,i) where put (a,b,c,d,e,f,g,h,i) = put (a,(b,c,d,e,f,g,h,i)) get = do (a,(b,c,d,e,f,g,h,i)) <- get ; return (a,b,c,d,e,f,g,h,i) instance (Binary a, Binary b, Binary c, Binary d, Binary e, Binary f, Binary g, Binary h, Binary i, Binary j) => Binary (a,b,c,d,e,f,g,h,i,j) where put (a,b,c,d,e,f,g,h,i,j) = put (a,(b,c,d,e,f,g,h,i,j)) get = do (a,(b,c,d,e,f,g,h,i,j)) <- get ; return (a,b,c,d,e,f,g,h,i,j) ------------------------------------------------------------------------ -- Container types instance Binary a => Binary [a] where put l = put (length l) >> mapM_ put l get = do n <- get :: Get Int getMany n -- | 'getMany n' get 'n' elements in order, without blowing the stack. getMany :: Binary a => Int -> Get [a] getMany n = go [] n where go xs 0 = return $! reverse xs go xs i = do x <- get -- we must seq x to avoid stack overflows due to laziness in -- (>>=) x `seq` go (x:xs) (i-1) {-# INLINE getMany #-} instance (Binary a) => Binary (Maybe a) where put Nothing = putWord8 0 put (Just x) = putWord8 1 >> put x get = do w <- getWord8 case w of 0 -> return Nothing _ -> liftM Just get instance (Binary a, Binary b) => Binary (Either a b) where put (Left a) = putWord8 0 >> put a put (Right b) = putWord8 1 >> put b get = do w <- getWord8 case w of 0 -> liftM Left get _ -> liftM Right get ------------------------------------------------------------------------ -- ByteStrings (have specially efficient instances) instance Binary B.ByteString where put bs = do put (B.length bs) putByteString bs get = get >>= getByteString -- -- Using old versions of fps, this is a type synonym, and non portable -- -- Requires 'flexible instances' -- instance Binary ByteString where put bs = do put (fromIntegral (L.length bs) :: Int) putLazyByteString bs get = get >>= getLazyByteString ------------------------------------------------------------------------ -- Maps and Sets instance (Binary a) => Binary (Set.Set a) where put s = put (Set.size s) >> mapM_ put (Set.toAscList s) get = liftM Set.fromDistinctAscList get instance (Binary k, Binary e) => Binary (Map.Map k e) where put m = put (Map.size m) >> mapM_ put (Map.toAscList m) get = liftM Map.fromDistinctAscList get instance Binary IntSet.IntSet where put s = put (IntSet.size s) >> mapM_ put (IntSet.toAscList s) get = liftM IntSet.fromDistinctAscList get instance (Binary e) => Binary (IntMap.IntMap e) where put m = put (IntMap.size m) >> mapM_ put (IntMap.toAscList m) get = liftM IntMap.fromDistinctAscList get ------------------------------------------------------------------------ -- Queues and Sequences #if __GLASGOW_HASKELL__ >= 606 -- -- This is valid Hugs, but you need the most recent Hugs -- instance (Binary e) => Binary (Seq.Seq e) where put s = put (Seq.length s) >> Fold.mapM_ put s get = do n <- get :: Get Int rep Seq.empty n get where rep xs 0 _ = return $! xs rep xs n g = xs `seq` n `seq` do x <- g rep (xs Seq.|> x) (n-1) g #endif ------------------------------------------------------------------------ -- Floating point instance Binary Double where put d = put (decodeFloat d) get = liftM2 encodeFloat get get instance Binary Float where put f = put (decodeFloat f) get = liftM2 encodeFloat get get ------------------------------------------------------------------------ -- Trees instance (Binary e) => Binary (T.Tree e) where put (T.Node r s) = put r >> put s get = liftM2 T.Node get get ------------------------------------------------------------------------ -- Arrays instance (Binary i, Ix i, Binary e) => Binary (Array i e) where put a = do put (bounds a) put (rangeSize $ bounds a) -- write the length mapM_ put (elems a) -- now the elems. get = do bs <- get n <- get -- read the length xs <- getMany n -- now the elems. return (listArray bs xs) -- -- The IArray UArray e constraint is non portable. Requires flexible instances -- instance (Binary i, Ix i, Binary e, IArray UArray e) => Binary (UArray i e) where put a = do put (bounds a) put (rangeSize $ bounds a) -- now write the length mapM_ put (elems a) get = do bs <- get n <- get xs <- getMany n return (listArray bs xs) Cabal-1.22.5.0/Distribution/Compat/Binary/Generic.hs0000644000000000000000000001054712627136220020175 0ustar0000000000000000{-# LANGUAGE BangPatterns, CPP, FlexibleInstances, KindSignatures, ScopedTypeVariables, Trustworthy, TypeOperators, TypeSynonymInstances #-} {-# OPTIONS_GHC -fno-warn-orphans #-} ----------------------------------------------------------------------------- -- | -- Module : Distribution.Compat.Binary.Generic -- Copyright : Bryan O'Sullivan -- License : BSD3-style (see LICENSE) -- -- Maintainer : Bryan O'Sullivan -- Stability : unstable -- Portability : Only works with GHC 7.2 and newer -- -- Instances for supporting GHC generics. -- ----------------------------------------------------------------------------- module Distribution.Compat.Binary.Generic ( ) where import Control.Applicative import Distribution.Compat.Binary.Class import Data.Binary.Get import Data.Binary.Put import Data.Bits import Data.Word import GHC.Generics -- Type without constructors instance GBinary V1 where gput _ = return () gget = return undefined -- Constructor without arguments instance GBinary U1 where gput U1 = return () gget = return U1 -- Product: constructor with parameters instance (GBinary a, GBinary b) => GBinary (a :*: b) where gput (x :*: y) = gput x >> gput y gget = (:*:) <$> gget <*> gget -- Metadata (constructor name, etc) instance GBinary a => GBinary (M1 i c a) where gput = gput . unM1 gget = M1 <$> gget -- Constants, additional parameters, and rank-1 recursion instance Binary a => GBinary (K1 i a) where gput = put . unK1 gget = K1 <$> get -- Borrowed from the cereal package. -- The following GBinary instance for sums has support for serializing -- types with up to 2^64-1 constructors. It will use the minimal -- number of bytes needed to encode the constructor. For example when -- a type has 2^8 constructors or less it will use a single byte to -- encode the constructor. If it has 2^16 constructors or less it will -- use two bytes, and so on till 2^64-1. #define GUARD(WORD) (size - 1) <= fromIntegral (maxBound :: WORD) #define PUTSUM(WORD) GUARD(WORD) = putSum (0 :: WORD) (fromIntegral size) #define GETSUM(WORD) GUARD(WORD) = (get :: Get WORD) >>= checkGetSum (fromIntegral size) instance ( GSum a, GSum b , GBinary a, GBinary b , SumSize a, SumSize b) => GBinary (a :+: b) where gput | PUTSUM(Word8) | PUTSUM(Word16) | PUTSUM(Word32) | PUTSUM(Word64) | otherwise = sizeError "encode" size where size = unTagged (sumSize :: Tagged (a :+: b) Word64) gget | GETSUM(Word8) | GETSUM(Word16) | GETSUM(Word32) | GETSUM(Word64) | otherwise = sizeError "decode" size where size = unTagged (sumSize :: Tagged (a :+: b) Word64) sizeError :: Show size => String -> size -> error sizeError s size = error $ "Can't " ++ s ++ " a type with " ++ show size ++ " constructors" ------------------------------------------------------------------------ checkGetSum :: (Ord word, Num word, Bits word, GSum f) => word -> word -> Get (f a) checkGetSum size code | code < size = getSum code size | otherwise = fail "Unknown encoding for constructor" {-# INLINE checkGetSum #-} class GSum f where getSum :: (Ord word, Num word, Bits word) => word -> word -> Get (f a) putSum :: (Num w, Bits w, Binary w) => w -> w -> f a -> Put instance (GSum a, GSum b, GBinary a, GBinary b) => GSum (a :+: b) where getSum !code !size | code < sizeL = L1 <$> getSum code sizeL | otherwise = R1 <$> getSum (code - sizeL) sizeR where sizeL = size `shiftR` 1 sizeR = size - sizeL putSum !code !size s = case s of L1 x -> putSum code sizeL x R1 x -> putSum (code + sizeL) sizeR x where sizeL = size `shiftR` 1 sizeR = size - sizeL instance GBinary a => GSum (C1 c a) where getSum _ _ = gget putSum !code _ x = put code *> gput x ------------------------------------------------------------------------ class SumSize f where sumSize :: Tagged f Word64 newtype Tagged (s :: * -> *) b = Tagged {unTagged :: b} instance (SumSize a, SumSize b) => SumSize (a :+: b) where sumSize = Tagged $ unTagged (sumSize :: Tagged a Word64) + unTagged (sumSize :: Tagged b Word64) instance SumSize (C1 c a) where sumSize = Tagged 1 Cabal-1.22.5.0/Distribution/PackageDescription/0000755000000000000000000000000012627136220017346 5ustar0000000000000000Cabal-1.22.5.0/Distribution/PackageDescription/Check.hs0000644000000000000000000020422512627136220020724 0ustar0000000000000000----------------------------------------------------------------------------- -- | -- Module : Distribution.PackageDescription.Check -- Copyright : Lennart Kolmodin 2008 -- License : BSD3 -- -- Maintainer : cabal-devel@haskell.org -- Portability : portable -- -- This has code for checking for various problems in packages. There is one -- set of checks that just looks at a 'PackageDescription' in isolation and -- another set of checks that also looks at files in the package. Some of the -- checks are basic sanity checks, others are portability standards that we'd -- like to encourage. There is a 'PackageCheck' type that distinguishes the -- different kinds of check so we can see which ones are appropriate to report -- in different situations. This code gets uses when configuring a package when -- we consider only basic problems. The higher standard is uses when when -- preparing a source tarball and by Hackage when uploading new packages. The -- reason for this is that we want to hold packages that are expected to be -- distributed to a higher standard than packages that are only ever expected -- to be used on the author's own environment. module Distribution.PackageDescription.Check ( -- * Package Checking PackageCheck(..), checkPackage, checkConfiguredPackage, -- ** Checking package contents checkPackageFiles, checkPackageContent, CheckPackageContentOps(..), checkPackageFileNames, ) where import Data.Maybe ( isNothing, isJust, catMaybes, maybeToList, fromMaybe ) import Data.List (sort, group, isPrefixOf, nub, find) import Control.Monad ( filterM, liftM ) import qualified System.Directory as System ( doesFileExist, doesDirectoryExist ) import qualified Data.Map as Map import Distribution.PackageDescription import Distribution.PackageDescription.Configuration ( flattenPackageDescription, finalizePackageDescription ) import Distribution.Compiler ( CompilerFlavor(..), buildCompilerFlavor, CompilerId(..) , unknownCompilerInfo, AbiTag(..) ) import Distribution.System ( OS(..), Arch(..), buildPlatform ) import Distribution.License ( License(..), knownLicenses ) import Distribution.Simple.CCompiler ( filenameCDialect ) import Distribution.Simple.Utils ( cabalVersion, intercalate, parseFileGlob, FileGlob(..), lowercase ) import Distribution.Version ( Version(..) , VersionRange(..), foldVersionRange' , anyVersion, noVersion, thisVersion, laterVersion, earlierVersion , orLaterVersion, orEarlierVersion , unionVersionRanges, intersectVersionRanges , asVersionIntervals, UpperBound(..), isNoVersion ) import Distribution.Package ( PackageName(PackageName), packageName, packageVersion , Dependency(..), pkgName ) import Distribution.Text ( display, disp ) import qualified Text.PrettyPrint as Disp import Text.PrettyPrint ((<>), (<+>)) import qualified Language.Haskell.Extension as Extension (deprecatedExtensions) import Language.Haskell.Extension ( Language(UnknownLanguage), knownLanguages , Extension(..), KnownExtension(..) ) import System.FilePath ( (), takeExtension, isRelative, isAbsolute , splitDirectories, splitPath ) import System.FilePath.Windows as FilePath.Windows ( isValid ) -- | Results of some kind of failed package check. -- -- There are a range of severities, from merely dubious to totally insane. -- All of them come with a human readable explanation. In future we may augment -- them with more machine readable explanations, for example to help an IDE -- suggest automatic corrections. -- data PackageCheck = -- | This package description is no good. There's no way it's going to -- build sensibly. This should give an error at configure time. PackageBuildImpossible { explanation :: String } -- | A problem that is likely to affect building the package, or an -- issue that we'd like every package author to be aware of, even if -- the package is never distributed. | PackageBuildWarning { explanation :: String } -- | An issue that might not be a problem for the package author but -- might be annoying or detrimental when the package is distributed to -- users. We should encourage distributed packages to be free from these -- issues, but occasionally there are justifiable reasons so we cannot -- ban them entirely. | PackageDistSuspicious { explanation :: String } -- | An issue that is OK in the author's environment but is almost -- certain to be a portability problem for other environments. We can -- quite legitimately refuse to publicly distribute packages with these -- problems. | PackageDistInexcusable { explanation :: String } deriving (Eq) instance Show PackageCheck where show notice = explanation notice check :: Bool -> PackageCheck -> Maybe PackageCheck check False _ = Nothing check True pc = Just pc checkSpecVersion :: PackageDescription -> [Int] -> Bool -> PackageCheck -> Maybe PackageCheck checkSpecVersion pkg specver cond pc | specVersion pkg >= Version specver [] = Nothing | otherwise = check cond pc -- ------------------------------------------------------------ -- * Standard checks -- ------------------------------------------------------------ -- | Check for common mistakes and problems in package descriptions. -- -- This is the standard collection of checks covering all aspects except -- for checks that require looking at files within the package. For those -- see 'checkPackageFiles'. -- -- It requires the 'GenericPackageDescription' and optionally a particular -- configuration of that package. If you pass 'Nothing' then we just check -- a version of the generic description using 'flattenPackageDescription'. -- checkPackage :: GenericPackageDescription -> Maybe PackageDescription -> [PackageCheck] checkPackage gpkg mpkg = checkConfiguredPackage pkg ++ checkConditionals gpkg ++ checkPackageVersions gpkg where pkg = fromMaybe (flattenPackageDescription gpkg) mpkg --TODO: make this variant go away -- we should always know the GenericPackageDescription checkConfiguredPackage :: PackageDescription -> [PackageCheck] checkConfiguredPackage pkg = checkSanity pkg ++ checkFields pkg ++ checkLicense pkg ++ checkSourceRepos pkg ++ checkGhcOptions pkg ++ checkCCOptions pkg ++ checkCPPOptions pkg ++ checkPaths pkg ++ checkCabalVersion pkg -- ------------------------------------------------------------ -- * Basic sanity checks -- ------------------------------------------------------------ -- | Check that this package description is sane. -- checkSanity :: PackageDescription -> [PackageCheck] checkSanity pkg = catMaybes [ check (null . (\(PackageName n) -> n) . packageName $ pkg) $ PackageBuildImpossible "No 'name' field." , check (null . versionBranch . packageVersion $ pkg) $ PackageBuildImpossible "No 'version' field." , check (null (executables pkg) && isNothing (library pkg)) $ PackageBuildImpossible "No executables and no library found. Nothing to do." , check (not (null duplicateNames)) $ PackageBuildImpossible $ "Duplicate sections: " ++ commaSep duplicateNames ++ ". The name of every executable, test suite, and benchmark section in" ++ " the package must be unique." ] --TODO: check for name clashes case insensitively: windows file systems cannot --cope. ++ maybe [] (checkLibrary pkg) (library pkg) ++ concatMap (checkExecutable pkg) (executables pkg) ++ concatMap (checkTestSuite pkg) (testSuites pkg) ++ concatMap (checkBenchmark pkg) (benchmarks pkg) ++ catMaybes [ check (specVersion pkg > cabalVersion) $ PackageBuildImpossible $ "This package description follows version " ++ display (specVersion pkg) ++ " of the Cabal specification. This " ++ "tool only supports up to version " ++ display cabalVersion ++ "." ] where exeNames = map exeName $ executables pkg testNames = map testName $ testSuites pkg bmNames = map benchmarkName $ benchmarks pkg duplicateNames = dups $ exeNames ++ testNames ++ bmNames checkLibrary :: PackageDescription -> Library -> [PackageCheck] checkLibrary pkg lib = catMaybes [ check (not (null moduleDuplicates)) $ PackageBuildImpossible $ "Duplicate modules in library: " ++ commaSep (map display moduleDuplicates) -- check use of required-signatures/exposed-signatures sections , checkVersion [1,21] (not (null (requiredSignatures lib))) $ PackageDistInexcusable $ "To use the 'required-signatures' field the package needs to specify " ++ "at least 'cabal-version: >= 1.21'." , checkVersion [1,21] (not (null (exposedSignatures lib))) $ PackageDistInexcusable $ "To use the 'exposed-signatures' field the package needs to specify " ++ "at least 'cabal-version: >= 1.21'." ] where checkVersion :: [Int] -> Bool -> PackageCheck -> Maybe PackageCheck checkVersion ver cond pc | specVersion pkg >= Version ver [] = Nothing | otherwise = check cond pc moduleDuplicates = dups (libModules lib ++ map moduleReexportName (reexportedModules lib)) checkExecutable :: PackageDescription -> Executable -> [PackageCheck] checkExecutable pkg exe = catMaybes [ check (null (modulePath exe)) $ PackageBuildImpossible $ "No 'main-is' field found for executable " ++ exeName exe , check (not (null (modulePath exe)) && (not $ fileExtensionSupportedLanguage $ modulePath exe)) $ PackageBuildImpossible $ "The 'main-is' field must specify a '.hs' or '.lhs' file " ++ "(even if it is generated by a preprocessor), " ++ "or it may specify a C/C++/obj-C source file." , checkSpecVersion pkg [1,17] (fileExtensionSupportedLanguage (modulePath exe) && takeExtension (modulePath exe) `notElem` [".hs", ".lhs"]) $ PackageDistInexcusable $ "The package uses a C/C++/obj-C source file for the 'main-is' field. " ++ "To use this feature you must specify 'cabal-version: >= 1.18'." , check (not (null moduleDuplicates)) $ PackageBuildImpossible $ "Duplicate modules in executable '" ++ exeName exe ++ "': " ++ commaSep (map display moduleDuplicates) ] where moduleDuplicates = dups (exeModules exe) checkTestSuite :: PackageDescription -> TestSuite -> [PackageCheck] checkTestSuite pkg test = catMaybes [ case testInterface test of TestSuiteUnsupported tt@(TestTypeUnknown _ _) -> Just $ PackageBuildWarning $ quote (display tt) ++ " is not a known type of test suite. " ++ "The known test suite types are: " ++ commaSep (map display knownTestTypes) TestSuiteUnsupported tt -> Just $ PackageBuildWarning $ quote (display tt) ++ " is not a supported test suite version. " ++ "The known test suite types are: " ++ commaSep (map display knownTestTypes) _ -> Nothing , check (not $ null moduleDuplicates) $ PackageBuildImpossible $ "Duplicate modules in test suite '" ++ testName test ++ "': " ++ commaSep (map display moduleDuplicates) , check mainIsWrongExt $ PackageBuildImpossible $ "The 'main-is' field must specify a '.hs' or '.lhs' file " ++ "(even if it is generated by a preprocessor), " ++ "or it may specify a C/C++/obj-C source file." , checkSpecVersion pkg [1,17] (mainIsNotHsExt && not mainIsWrongExt) $ PackageDistInexcusable $ "The package uses a C/C++/obj-C source file for the 'main-is' field. " ++ "To use this feature you must specify 'cabal-version: >= 1.18'." -- Test suites might be built as (internal) libraries named after -- the test suite and thus their names must not clash with the -- name of the package. , check libNameClash $ PackageBuildImpossible $ "The test suite " ++ testName test ++ " has the same name as the package." ] where moduleDuplicates = dups $ testModules test mainIsWrongExt = case testInterface test of TestSuiteExeV10 _ f -> not $ fileExtensionSupportedLanguage f _ -> False mainIsNotHsExt = case testInterface test of TestSuiteExeV10 _ f -> takeExtension f `notElem` [".hs", ".lhs"] _ -> False libNameClash = testName test `elem` [ libName | _lib <- maybeToList (library pkg) , let PackageName libName = pkgName (package pkg) ] checkBenchmark :: PackageDescription -> Benchmark -> [PackageCheck] checkBenchmark pkg bm = catMaybes [ case benchmarkInterface bm of BenchmarkUnsupported tt@(BenchmarkTypeUnknown _ _) -> Just $ PackageBuildWarning $ quote (display tt) ++ " is not a known type of benchmark. " ++ "The known benchmark types are: " ++ commaSep (map display knownBenchmarkTypes) BenchmarkUnsupported tt -> Just $ PackageBuildWarning $ quote (display tt) ++ " is not a supported benchmark version. " ++ "The known benchmark types are: " ++ commaSep (map display knownBenchmarkTypes) _ -> Nothing , check (not $ null moduleDuplicates) $ PackageBuildImpossible $ "Duplicate modules in benchmark '" ++ benchmarkName bm ++ "': " ++ commaSep (map display moduleDuplicates) , check mainIsWrongExt $ PackageBuildImpossible $ "The 'main-is' field must specify a '.hs' or '.lhs' file " ++ "(even if it is generated by a preprocessor)." -- See comment for similar check on test suites. , check libNameClash $ PackageBuildImpossible $ "The benchmark " ++ benchmarkName bm ++ " has the same name as the package." ] where moduleDuplicates = dups $ benchmarkModules bm mainIsWrongExt = case benchmarkInterface bm of BenchmarkExeV10 _ f -> takeExtension f `notElem` [".hs", ".lhs"] _ -> False libNameClash = benchmarkName bm `elem` [ libName | _lib <- maybeToList (library pkg) , let PackageName libName = pkgName (package pkg) ] -- ------------------------------------------------------------ -- * Additional pure checks -- ------------------------------------------------------------ checkFields :: PackageDescription -> [PackageCheck] checkFields pkg = catMaybes [ check (not . FilePath.Windows.isValid . display . packageName $ pkg) $ PackageDistInexcusable $ "Unfortunately, the package name '" ++ display (packageName pkg) ++ "' is one of the reserved system file names on Windows. Many tools " ++ "need to convert package names to file names so using this name " ++ "would cause problems." , check (isNothing (buildType pkg)) $ PackageBuildWarning $ "No 'build-type' specified. If you do not need a custom Setup.hs or " ++ "./configure script then use 'build-type: Simple'." , case buildType pkg of Just (UnknownBuildType unknown) -> Just $ PackageBuildWarning $ quote unknown ++ " is not a known 'build-type'. " ++ "The known build types are: " ++ commaSep (map display knownBuildTypes) _ -> Nothing , check (not (null unknownCompilers)) $ PackageBuildWarning $ "Unknown compiler " ++ commaSep (map quote unknownCompilers) ++ " in 'tested-with' field." , check (not (null unknownLanguages)) $ PackageBuildWarning $ "Unknown languages: " ++ commaSep unknownLanguages , check (not (null unknownExtensions)) $ PackageBuildWarning $ "Unknown extensions: " ++ commaSep unknownExtensions , check (not (null languagesUsedAsExtensions)) $ PackageBuildWarning $ "Languages listed as extensions: " ++ commaSep languagesUsedAsExtensions ++ ". Languages must be specified in either the 'default-language' " ++ " or the 'other-languages' field." , check (not (null deprecatedExtensions)) $ PackageDistSuspicious $ "Deprecated extensions: " ++ commaSep (map (quote . display . fst) deprecatedExtensions) ++ ". " ++ unwords [ "Instead of '" ++ display ext ++ "' use '" ++ display replacement ++ "'." | (ext, Just replacement) <- deprecatedExtensions ] , check (null (category pkg)) $ PackageDistSuspicious "No 'category' field." , check (null (maintainer pkg)) $ PackageDistSuspicious "No 'maintainer' field." , check (null (synopsis pkg) && null (description pkg)) $ PackageDistInexcusable "No 'synopsis' or 'description' field." , check (null (description pkg) && not (null (synopsis pkg))) $ PackageDistSuspicious "No 'description' field." , check (null (synopsis pkg) && not (null (description pkg))) $ PackageDistSuspicious "No 'synopsis' field." --TODO: recommend the bug reports URL, author and homepage fields --TODO: recommend not using the stability field --TODO: recommend specifying a source repo , check (length (synopsis pkg) >= 80) $ PackageDistSuspicious "The 'synopsis' field is rather long (max 80 chars is recommended)." -- check use of impossible constraints "tested-with: GHC== 6.10 && ==6.12" , check (not (null testedWithImpossibleRanges)) $ PackageDistInexcusable $ "Invalid 'tested-with' version range: " ++ commaSep (map display testedWithImpossibleRanges) ++ ". To indicate that you have tested a package with multiple " ++ "different versions of the same compiler use multiple entries, " ++ "for example 'tested-with: GHC==6.10.4, GHC==6.12.3' and not " ++ "'tested-with: GHC==6.10.4 && ==6.12.3'." ] where unknownCompilers = [ name | (OtherCompiler name, _) <- testedWith pkg ] unknownLanguages = [ name | bi <- allBuildInfo pkg , UnknownLanguage name <- allLanguages bi ] unknownExtensions = [ name | bi <- allBuildInfo pkg , UnknownExtension name <- allExtensions bi , name `notElem` map display knownLanguages ] deprecatedExtensions = nub $ catMaybes [ find ((==ext) . fst) Extension.deprecatedExtensions | bi <- allBuildInfo pkg , ext <- allExtensions bi ] languagesUsedAsExtensions = [ name | bi <- allBuildInfo pkg , UnknownExtension name <- allExtensions bi , name `elem` map display knownLanguages ] testedWithImpossibleRanges = [ Dependency (PackageName (display compiler)) vr | (compiler, vr) <- testedWith pkg , isNoVersion vr ] checkLicense :: PackageDescription -> [PackageCheck] checkLicense pkg = catMaybes [ check (license pkg == UnspecifiedLicense) $ PackageDistInexcusable "The 'license' field is missing." , check (license pkg == AllRightsReserved) $ PackageDistSuspicious "The 'license' is AllRightsReserved. Is that really what you want?" , case license pkg of UnknownLicense l -> Just $ PackageBuildWarning $ quote ("license: " ++ l) ++ " is not a recognised license. The " ++ "known licenses are: " ++ commaSep (map display knownLicenses) _ -> Nothing , check (license pkg == BSD4) $ PackageDistSuspicious $ "Using 'license: BSD4' is almost always a misunderstanding. 'BSD4' " ++ "refers to the old 4-clause BSD license with the advertising " ++ "clause. 'BSD3' refers the new 3-clause BSD license." , case unknownLicenseVersion (license pkg) of Just knownVersions -> Just $ PackageDistSuspicious $ "'license: " ++ display (license pkg) ++ "' is not a known " ++ "version of that license. The known versions are " ++ commaSep (map display knownVersions) ++ ". If this is not a mistake and you think it should be a known " ++ "version then please file a ticket." _ -> Nothing , check (license pkg `notElem` [ AllRightsReserved , UnspecifiedLicense, PublicDomain] -- AllRightsReserved and PublicDomain are not strictly -- licenses so don't need license files. && null (licenseFiles pkg)) $ PackageDistSuspicious "A 'license-file' is not specified." ] where unknownLicenseVersion (GPL (Just v)) | v `notElem` knownVersions = Just knownVersions where knownVersions = [ v' | GPL (Just v') <- knownLicenses ] unknownLicenseVersion (LGPL (Just v)) | v `notElem` knownVersions = Just knownVersions where knownVersions = [ v' | LGPL (Just v') <- knownLicenses ] unknownLicenseVersion (AGPL (Just v)) | v `notElem` knownVersions = Just knownVersions where knownVersions = [ v' | AGPL (Just v') <- knownLicenses ] unknownLicenseVersion (Apache (Just v)) | v `notElem` knownVersions = Just knownVersions where knownVersions = [ v' | Apache (Just v') <- knownLicenses ] unknownLicenseVersion _ = Nothing checkSourceRepos :: PackageDescription -> [PackageCheck] checkSourceRepos pkg = catMaybes $ concat [[ case repoKind repo of RepoKindUnknown kind -> Just $ PackageDistInexcusable $ quote kind ++ " is not a recognised kind of source-repository. " ++ "The repo kind is usually 'head' or 'this'" _ -> Nothing , check (isNothing (repoType repo)) $ PackageDistInexcusable "The source-repository 'type' is a required field." , check (isNothing (repoLocation repo)) $ PackageDistInexcusable "The source-repository 'location' is a required field." , check (repoType repo == Just CVS && isNothing (repoModule repo)) $ PackageDistInexcusable "For a CVS source-repository, the 'module' is a required field." , check (repoKind repo == RepoThis && isNothing (repoTag repo)) $ PackageDistInexcusable $ "For the 'this' kind of source-repository, the 'tag' is a required " ++ "field. It should specify the tag corresponding to this version " ++ "or release of the package." , check (maybe False System.FilePath.isAbsolute (repoSubdir repo)) $ PackageDistInexcusable "The 'subdir' field of a source-repository must be a relative path." ] | repo <- sourceRepos pkg ] --TODO: check location looks like a URL for some repo types. checkGhcOptions :: PackageDescription -> [PackageCheck] checkGhcOptions pkg = catMaybes [ check has_WerrorWall $ PackageDistSuspicious $ "'ghc-options: -Wall -Werror' makes the package very easy to " ++ "break with future GHC versions because new GHC versions often " ++ "add new warnings. Use just 'ghc-options: -Wall' instead." , check (not has_WerrorWall && has_Werror) $ PackageDistSuspicious $ "'ghc-options: -Werror' makes the package easy to " ++ "break with future GHC versions because new GHC versions often " ++ "add new warnings." , checkFlags ["-fasm"] $ PackageDistInexcusable $ "'ghc-options: -fasm' is unnecessary and will not work on CPU " ++ "architectures other than x86, x86-64, ppc or sparc." , checkFlags ["-fvia-C"] $ PackageDistSuspicious $ "'ghc-options: -fvia-C' is usually unnecessary. If your package " ++ "needs -via-C for correctness rather than performance then it " ++ "is using the FFI incorrectly and will probably not work with GHC " ++ "6.10 or later." , checkFlags ["-fdefer-type-errors"] $ PackageDistInexcusable $ "'ghc-options: -fdefer-type-errors' is fine during development but " ++ "is not appropriate for a distributed package." , checkFlags ["-fhpc"] $ PackageDistInexcusable $ "'ghc-options: -fhpc' is not appropriate for a distributed package." -- -dynamic is not a debug flag , check (any (\opt -> "-d" `isPrefixOf` opt && opt /= "-dynamic") all_ghc_options) $ PackageDistInexcusable $ "'ghc-options: -d*' debug flags are not appropriate " ++ "for a distributed package." , checkFlags ["-prof"] $ PackageBuildWarning $ "'ghc-options: -prof' is not necessary and will lead to problems " ++ "when used on a library. Use the configure flag " ++ "--enable-library-profiling and/or --enable-executable-profiling." , checkFlags ["-o"] $ PackageBuildWarning $ "'ghc-options: -o' is not needed. " ++ "The output files are named automatically." , checkFlags ["-hide-package"] $ PackageBuildWarning $ "'ghc-options: -hide-package' is never needed. " ++ "Cabal hides all packages." , checkFlags ["--make"] $ PackageBuildWarning $ "'ghc-options: --make' is never needed. Cabal uses this automatically." , checkFlags ["-main-is"] $ PackageDistSuspicious $ "'ghc-options: -main-is' is not portable." , checkFlags ["-O0", "-Onot"] $ PackageDistSuspicious $ "'ghc-options: -O0' is not needed. " ++ "Use the --disable-optimization configure flag." , checkFlags [ "-O", "-O1"] $ PackageDistInexcusable $ "'ghc-options: -O' is not needed. " ++ "Cabal automatically adds the '-O' flag. " ++ "Setting it yourself interferes with the --disable-optimization flag." , checkFlags ["-O2"] $ PackageDistSuspicious $ "'ghc-options: -O2' is rarely needed. " ++ "Check that it is giving a real benefit " ++ "and not just imposing longer compile times on your users." , checkFlags ["-split-objs"] $ PackageBuildWarning $ "'ghc-options: -split-objs' is not needed. " ++ "Use the --enable-split-objs configure flag." , checkFlags ["-optl-Wl,-s", "-optl-s"] $ PackageDistInexcusable $ "'ghc-options: -optl-Wl,-s' is not needed and is not portable to all" ++ " operating systems. Cabal 1.4 and later automatically strip" ++ " executables. Cabal also has a flag --disable-executable-stripping" ++ " which is necessary when building packages for some Linux" ++ " distributions and using '-optl-Wl,-s' prevents that from working." , checkFlags ["-fglasgow-exts"] $ PackageDistSuspicious $ "Instead of 'ghc-options: -fglasgow-exts' it is preferable to use " ++ "the 'extensions' field." , checkProfFlags ["-auto-all"] $ PackageDistSuspicious $ "'ghc-prof-options: -auto-all' is fine during development, but " ++ "not recommended in a distributed package. " , checkProfFlags ["-fprof-auto"] $ PackageDistSuspicious $ "'ghc-prof-options: -fprof-auto' is fine during development, but " ++ "not recommended in a distributed package. " , check ("-threaded" `elem` lib_ghc_options) $ PackageDistSuspicious $ "'ghc-options: -threaded' has no effect for libraries. It should " ++ "only be used for executables." , checkAlternatives "ghc-options" "extensions" [ (flag, display extension) | flag <- all_ghc_options , Just extension <- [ghcExtension flag] ] , checkAlternatives "ghc-options" "extensions" [ (flag, extension) | flag@('-':'X':extension) <- all_ghc_options ] , checkAlternatives "ghc-options" "cpp-options" $ [ (flag, flag) | flag@('-':'D':_) <- all_ghc_options ] ++ [ (flag, flag) | flag@('-':'U':_) <- all_ghc_options ] , checkAlternatives "ghc-options" "include-dirs" [ (flag, dir) | flag@('-':'I':dir) <- all_ghc_options ] , checkAlternatives "ghc-options" "extra-libraries" [ (flag, lib) | flag@('-':'l':lib) <- all_ghc_options ] , checkAlternatives "ghc-options" "extra-lib-dirs" [ (flag, dir) | flag@('-':'L':dir) <- all_ghc_options ] ] where has_WerrorWall = flip any ghc_options $ \opts -> "-Werror" `elem` opts && ("-Wall" `elem` opts || "-W" `elem` opts) has_Werror = any (\opts -> "-Werror" `elem` opts) ghc_options (ghc_options, ghc_prof_options) = unzip . map (\bi -> (hcOptions GHC bi, hcProfOptions GHC bi)) $ (allBuildInfo pkg) all_ghc_options = concat ghc_options all_ghc_prof_options = concat ghc_prof_options lib_ghc_options = maybe [] (hcOptions GHC . libBuildInfo) (library pkg) checkFlags,checkProfFlags :: [String] -> PackageCheck -> Maybe PackageCheck checkFlags flags = doCheckFlags flags all_ghc_options checkProfFlags flags = doCheckFlags flags all_ghc_prof_options doCheckFlags flags opts = check (any (`elem` flags) opts) ghcExtension ('-':'f':name) = case name of "allow-overlapping-instances" -> enable OverlappingInstances "no-allow-overlapping-instances" -> disable OverlappingInstances "th" -> enable TemplateHaskell "no-th" -> disable TemplateHaskell "ffi" -> enable ForeignFunctionInterface "no-ffi" -> disable ForeignFunctionInterface "fi" -> enable ForeignFunctionInterface "no-fi" -> disable ForeignFunctionInterface "monomorphism-restriction" -> enable MonomorphismRestriction "no-monomorphism-restriction" -> disable MonomorphismRestriction "mono-pat-binds" -> enable MonoPatBinds "no-mono-pat-binds" -> disable MonoPatBinds "allow-undecidable-instances" -> enable UndecidableInstances "no-allow-undecidable-instances" -> disable UndecidableInstances "allow-incoherent-instances" -> enable IncoherentInstances "no-allow-incoherent-instances" -> disable IncoherentInstances "arrows" -> enable Arrows "no-arrows" -> disable Arrows "generics" -> enable Generics "no-generics" -> disable Generics "implicit-prelude" -> enable ImplicitPrelude "no-implicit-prelude" -> disable ImplicitPrelude "implicit-params" -> enable ImplicitParams "no-implicit-params" -> disable ImplicitParams "bang-patterns" -> enable BangPatterns "no-bang-patterns" -> disable BangPatterns "scoped-type-variables" -> enable ScopedTypeVariables "no-scoped-type-variables" -> disable ScopedTypeVariables "extended-default-rules" -> enable ExtendedDefaultRules "no-extended-default-rules" -> disable ExtendedDefaultRules _ -> Nothing ghcExtension "-cpp" = enable CPP ghcExtension _ = Nothing enable e = Just (EnableExtension e) disable e = Just (DisableExtension e) checkCCOptions :: PackageDescription -> [PackageCheck] checkCCOptions pkg = catMaybes [ checkAlternatives "cc-options" "include-dirs" [ (flag, dir) | flag@('-':'I':dir) <- all_ccOptions ] , checkAlternatives "cc-options" "extra-libraries" [ (flag, lib) | flag@('-':'l':lib) <- all_ccOptions ] , checkAlternatives "cc-options" "extra-lib-dirs" [ (flag, dir) | flag@('-':'L':dir) <- all_ccOptions ] , checkAlternatives "ld-options" "extra-libraries" [ (flag, lib) | flag@('-':'l':lib) <- all_ldOptions ] , checkAlternatives "ld-options" "extra-lib-dirs" [ (flag, dir) | flag@('-':'L':dir) <- all_ldOptions ] , checkCCFlags [ "-O", "-Os", "-O0", "-O1", "-O2", "-O3" ] $ PackageDistSuspicious $ "'cc-options: -O[n]' is generally not needed. When building with " ++ " optimisations Cabal automatically adds '-O2' for C code. " ++ "Setting it yourself interferes with the --disable-optimization " ++ "flag." ] where all_ccOptions = [ opts | bi <- allBuildInfo pkg , opts <- ccOptions bi ] all_ldOptions = [ opts | bi <- allBuildInfo pkg , opts <- ldOptions bi ] checkCCFlags :: [String] -> PackageCheck -> Maybe PackageCheck checkCCFlags flags = check (any (`elem` flags) all_ccOptions) checkCPPOptions :: PackageDescription -> [PackageCheck] checkCPPOptions pkg = catMaybes [ checkAlternatives "cpp-options" "include-dirs" [ (flag, dir) | flag@('-':'I':dir) <- all_cppOptions] ] where all_cppOptions = [ opts | bi <- allBuildInfo pkg , opts <- cppOptions bi ] checkAlternatives :: String -> String -> [(String, String)] -> Maybe PackageCheck checkAlternatives badField goodField flags = check (not (null badFlags)) $ PackageBuildWarning $ "Instead of " ++ quote (badField ++ ": " ++ unwords badFlags) ++ " use " ++ quote (goodField ++ ": " ++ unwords goodFlags) where (badFlags, goodFlags) = unzip flags checkPaths :: PackageDescription -> [PackageCheck] checkPaths pkg = [ PackageBuildWarning $ quote (kind ++ ": " ++ path) ++ " is a relative path outside of the source tree. " ++ "This will not work when generating a tarball with 'sdist'." | (path, kind) <- relPaths ++ absPaths , isOutsideTree path ] ++ [ PackageDistInexcusable $ quote (kind ++ ": " ++ path) ++ " is an absolute directory." | (path, kind) <- relPaths , isAbsolute path ] ++ [ PackageDistInexcusable $ quote (kind ++ ": " ++ path) ++ " points inside the 'dist' " ++ "directory. This is not reliable because the location of this " ++ "directory is configurable by the user (or package manager). In " ++ "addition the layout of the 'dist' directory is subject to change " ++ "in future versions of Cabal." | (path, kind) <- relPaths ++ absPaths , isInsideDist path ] ++ [ PackageDistInexcusable $ "The 'ghc-options' contains the path '" ++ path ++ "' which points " ++ "inside the 'dist' directory. This is not reliable because the " ++ "location of this directory is configurable by the user (or package " ++ "manager). In addition the layout of the 'dist' directory is subject " ++ "to change in future versions of Cabal." | bi <- allBuildInfo pkg , (GHC, flags) <- options bi , path <- flags , isInsideDist path ] where isOutsideTree path = case splitDirectories path of "..":_ -> True ".":"..":_ -> True _ -> False isInsideDist path = case map lowercase (splitDirectories path) of "dist" :_ -> True ".":"dist":_ -> True _ -> False -- paths that must be relative relPaths = [ (path, "extra-src-files") | path <- extraSrcFiles pkg ] ++ [ (path, "extra-tmp-files") | path <- extraTmpFiles pkg ] ++ [ (path, "extra-doc-files") | path <- extraDocFiles pkg ] ++ [ (path, "data-files") | path <- dataFiles pkg ] ++ [ (path, "data-dir") | path <- [dataDir pkg]] ++ concat [ [ (path, "c-sources") | path <- cSources bi ] ++ [ (path, "js-sources") | path <- jsSources bi ] ++ [ (path, "install-includes") | path <- installIncludes bi ] ++ [ (path, "hs-source-dirs") | path <- hsSourceDirs bi ] | bi <- allBuildInfo pkg ] -- paths that are allowed to be absolute absPaths = concat [ [ (path, "includes") | path <- includes bi ] ++ [ (path, "include-dirs") | path <- includeDirs bi ] ++ [ (path, "extra-lib-dirs") | path <- extraLibDirs bi ] | bi <- allBuildInfo pkg ] --TODO: check sets of paths that would be interpreted differently between Unix -- and windows, ie case-sensitive or insensitive. Things that might clash, or -- conversely be distinguished. --TODO: use the tar path checks on all the above paths -- | Check that the package declares the version in the @\"cabal-version\"@ -- field correctly. -- checkCabalVersion :: PackageDescription -> [PackageCheck] checkCabalVersion pkg = catMaybes [ -- check syntax of cabal-version field check (specVersion pkg >= Version [1,10] [] && not simpleSpecVersionRangeSyntax) $ PackageBuildWarning $ "Packages relying on Cabal 1.10 or later must only specify a " ++ "version range of the form 'cabal-version: >= x.y'. Use " ++ "'cabal-version: >= " ++ display (specVersion pkg) ++ "'." -- check syntax of cabal-version field , check (specVersion pkg < Version [1,9] [] && not simpleSpecVersionRangeSyntax) $ PackageDistSuspicious $ "It is recommended that the 'cabal-version' field only specify a " ++ "version range of the form '>= x.y'. Use " ++ "'cabal-version: >= " ++ display (specVersion pkg) ++ "'. " ++ "Tools based on Cabal 1.10 and later will ignore upper bounds." -- check syntax of cabal-version field , checkVersion [1,12] simpleSpecVersionSyntax $ PackageBuildWarning $ "With Cabal 1.10 or earlier, the 'cabal-version' field must use " ++ "range syntax rather than a simple version number. Use " ++ "'cabal-version: >= " ++ display (specVersion pkg) ++ "'." -- check use of test suite sections , checkVersion [1,8] (not (null $ testSuites pkg)) $ PackageDistInexcusable $ "The 'test-suite' section is new in Cabal 1.10. " ++ "Unfortunately it messes up the parser in older Cabal versions " ++ "so you must specify at least 'cabal-version: >= 1.8', but note " ++ "that only Cabal 1.10 and later can actually run such test suites." -- check use of default-language field -- note that we do not need to do an equivalent check for the -- other-language field since that one does not change behaviour , checkVersion [1,10] (any isJust (buildInfoField defaultLanguage)) $ PackageBuildWarning $ "To use the 'default-language' field the package needs to specify " ++ "at least 'cabal-version: >= 1.10'." , check (specVersion pkg >= Version [1,10] [] && (any isNothing (buildInfoField defaultLanguage))) $ PackageBuildWarning $ "Packages using 'cabal-version: >= 1.10' must specify the " ++ "'default-language' field for each component (e.g. Haskell98 or " ++ "Haskell2010). If a component uses different languages in " ++ "different modules then list the other ones in the " ++ "'other-languages' field." -- check use of reexported-modules sections , checkVersion [1,21] (maybe False (not.null.reexportedModules) (library pkg)) $ PackageDistInexcusable $ "To use the 'reexported-module' field the package needs to specify " ++ "at least 'cabal-version: >= 1.21'." -- check use of thinning and renaming , checkVersion [1,21] (not (null depsUsingThinningRenamingSyntax)) $ PackageDistInexcusable $ "The package uses " ++ "thinning and renaming in the 'build-depends' field: " ++ commaSep (map display depsUsingThinningRenamingSyntax) ++ ". To use this new syntax, the package needs to specify at least" ++ "'cabal-version: >= 1.21'." -- check use of default-extensions field -- don't need to do the equivalent check for other-extensions , checkVersion [1,10] (any (not . null) (buildInfoField defaultExtensions)) $ PackageBuildWarning $ "To use the 'default-extensions' field the package needs to specify " ++ "at least 'cabal-version: >= 1.10'." -- check use of extensions field , check (specVersion pkg >= Version [1,10] [] && (any (not . null) (buildInfoField oldExtensions))) $ PackageBuildWarning $ "For packages using 'cabal-version: >= 1.10' the 'extensions' " ++ "field is deprecated. The new 'default-extensions' field lists " ++ "extensions that are used in all modules in the component, while " ++ "the 'other-extensions' field lists extensions that are used in " ++ "some modules, e.g. via the {-# LANGUAGE #-} pragma." -- check use of "foo (>= 1.0 && < 1.4) || >=1.8 " version-range syntax , checkVersion [1,8] (not (null versionRangeExpressions)) $ PackageDistInexcusable $ "The package uses full version-range expressions " ++ "in a 'build-depends' field: " ++ commaSep (map displayRawDependency versionRangeExpressions) ++ ". To use this new syntax the package needs to specify at least " ++ "'cabal-version: >= 1.8'. Alternatively, if broader compatibility " ++ "is important, then convert to conjunctive normal form, and use " ++ "multiple 'build-depends:' lines, one conjunct per line." -- check use of "build-depends: foo == 1.*" syntax , checkVersion [1,6] (not (null depsUsingWildcardSyntax)) $ PackageDistInexcusable $ "The package uses wildcard syntax in the 'build-depends' field: " ++ commaSep (map display depsUsingWildcardSyntax) ++ ". To use this new syntax the package need to specify at least " ++ "'cabal-version: >= 1.6'. Alternatively, if broader compatibility " ++ "is important then use: " ++ commaSep [ display (Dependency name (eliminateWildcardSyntax versionRange)) | Dependency name versionRange <- depsUsingWildcardSyntax ] -- check use of "tested-with: GHC (>= 1.0 && < 1.4) || >=1.8 " syntax , checkVersion [1,8] (not (null testedWithVersionRangeExpressions)) $ PackageDistInexcusable $ "The package uses full version-range expressions " ++ "in a 'tested-with' field: " ++ commaSep (map displayRawDependency testedWithVersionRangeExpressions) ++ ". To use this new syntax the package needs to specify at least " ++ "'cabal-version: >= 1.8'." -- check use of "tested-with: GHC == 6.12.*" syntax , checkVersion [1,6] (not (null testedWithUsingWildcardSyntax)) $ PackageDistInexcusable $ "The package uses wildcard syntax in the 'tested-with' field: " ++ commaSep (map display testedWithUsingWildcardSyntax) ++ ". To use this new syntax the package need to specify at least " ++ "'cabal-version: >= 1.6'. Alternatively, if broader compatibility " ++ "is important then use: " ++ commaSep [ display (Dependency name (eliminateWildcardSyntax versionRange)) | Dependency name versionRange <- testedWithUsingWildcardSyntax ] -- check use of "data-files: data/*.txt" syntax , checkVersion [1,6] (not (null dataFilesUsingGlobSyntax)) $ PackageDistInexcusable $ "Using wildcards like " ++ commaSep (map quote $ take 3 dataFilesUsingGlobSyntax) ++ " in the 'data-files' field requires 'cabal-version: >= 1.6'. " ++ "Alternatively if you require compatibility with earlier Cabal " ++ "versions then list all the files explicitly." -- check use of "extra-source-files: mk/*.in" syntax , checkVersion [1,6] (not (null extraSrcFilesUsingGlobSyntax)) $ PackageDistInexcusable $ "Using wildcards like " ++ commaSep (map quote $ take 3 extraSrcFilesUsingGlobSyntax) ++ " in the 'extra-source-files' field requires " ++ "'cabal-version: >= 1.6'. Alternatively if you require " ++ "compatibility with earlier Cabal versions then list all the files " ++ "explicitly." -- check use of "source-repository" section , checkVersion [1,6] (not (null (sourceRepos pkg))) $ PackageDistInexcusable $ "The 'source-repository' section is new in Cabal 1.6. " ++ "Unfortunately it messes up the parser in earlier Cabal versions " ++ "so you need to specify 'cabal-version: >= 1.6'." -- check for new licenses , checkVersion [1,4] (license pkg `notElem` compatLicenses) $ PackageDistInexcusable $ "Unfortunately the license " ++ quote (display (license pkg)) ++ " messes up the parser in earlier Cabal versions so you need to " ++ "specify 'cabal-version: >= 1.4'. Alternatively if you require " ++ "compatibility with earlier Cabal versions then use 'OtherLicense'." -- check for new language extensions , checkVersion [1,2,3] (not (null mentionedExtensionsThatNeedCabal12)) $ PackageDistInexcusable $ "Unfortunately the language extensions " ++ commaSep (map (quote . display) mentionedExtensionsThatNeedCabal12) ++ " break the parser in earlier Cabal versions so you need to " ++ "specify 'cabal-version: >= 1.2.3'. Alternatively if you require " ++ "compatibility with earlier Cabal versions then you may be able to " ++ "use an equivalent compiler-specific flag." , checkVersion [1,4] (not (null mentionedExtensionsThatNeedCabal14)) $ PackageDistInexcusable $ "Unfortunately the language extensions " ++ commaSep (map (quote . display) mentionedExtensionsThatNeedCabal14) ++ " break the parser in earlier Cabal versions so you need to " ++ "specify 'cabal-version: >= 1.4'. Alternatively if you require " ++ "compatibility with earlier Cabal versions then you may be able to " ++ "use an equivalent compiler-specific flag." ] where -- Perform a check on packages that use a version of the spec less than -- the version given. This is for cases where a new Cabal version adds -- a new feature and we want to check that it is not used prior to that -- version. checkVersion :: [Int] -> Bool -> PackageCheck -> Maybe PackageCheck checkVersion ver cond pc | specVersion pkg >= Version ver [] = Nothing | otherwise = check cond pc buildInfoField field = map field (allBuildInfo pkg) dataFilesUsingGlobSyntax = filter usesGlobSyntax (dataFiles pkg) extraSrcFilesUsingGlobSyntax = filter usesGlobSyntax (extraSrcFiles pkg) usesGlobSyntax str = case parseFileGlob str of Just (FileGlob _ _) -> True _ -> False versionRangeExpressions = [ dep | dep@(Dependency _ vr) <- buildDepends pkg , usesNewVersionRangeSyntax vr ] testedWithVersionRangeExpressions = [ Dependency (PackageName (display compiler)) vr | (compiler, vr) <- testedWith pkg , usesNewVersionRangeSyntax vr ] simpleSpecVersionRangeSyntax = either (const True) (foldVersionRange' True (\_ -> False) (\_ -> False) (\_ -> False) (\_ -> True) -- >= (\_ -> False) (\_ _ -> False) (\_ _ -> False) (\_ _ -> False) id) (specVersionRaw pkg) -- is the cabal-version field a simple version number, rather than a range simpleSpecVersionSyntax = either (const True) (const False) (specVersionRaw pkg) usesNewVersionRangeSyntax :: VersionRange -> Bool usesNewVersionRangeSyntax = (> 2) -- uses the new syntax if depth is more than 2 . foldVersionRange' (1 :: Int) (const 1) (const 1) (const 1) (const 1) (const 1) (const (const 1)) (+) (+) (const 3) -- uses new ()'s syntax depsUsingWildcardSyntax = [ dep | dep@(Dependency _ vr) <- buildDepends pkg , usesWildcardSyntax vr ] -- XXX: If the user writes build-depends: foo with (), this is -- indistinguishable from build-depends: foo, so there won't be an -- error even though there should be depsUsingThinningRenamingSyntax = [ name | bi <- allBuildInfo pkg , (name, rns) <- Map.toList (targetBuildRenaming bi) , rns /= ModuleRenaming True [] ] testedWithUsingWildcardSyntax = [ Dependency (PackageName (display compiler)) vr | (compiler, vr) <- testedWith pkg , usesWildcardSyntax vr ] usesWildcardSyntax :: VersionRange -> Bool usesWildcardSyntax = foldVersionRange' False (const False) (const False) (const False) (const False) (const False) (\_ _ -> True) -- the wildcard case (||) (||) id eliminateWildcardSyntax = foldVersionRange' anyVersion thisVersion laterVersion earlierVersion orLaterVersion orEarlierVersion (\v v' -> intersectVersionRanges (orLaterVersion v) (earlierVersion v')) intersectVersionRanges unionVersionRanges id compatLicenses = [ GPL Nothing, LGPL Nothing, AGPL Nothing, BSD3, BSD4 , PublicDomain, AllRightsReserved , UnspecifiedLicense, OtherLicense ] mentionedExtensions = [ ext | bi <- allBuildInfo pkg , ext <- allExtensions bi ] mentionedExtensionsThatNeedCabal12 = nub (filter (`elem` compatExtensionsExtra) mentionedExtensions) -- As of Cabal-1.4 we can add new extensions without worrying about -- breaking old versions of cabal. mentionedExtensionsThatNeedCabal14 = nub (filter (`notElem` compatExtensions) mentionedExtensions) -- The known extensions in Cabal-1.2.3 compatExtensions = map EnableExtension [ OverlappingInstances, UndecidableInstances, IncoherentInstances , RecursiveDo, ParallelListComp, MultiParamTypeClasses , FunctionalDependencies, Rank2Types , RankNTypes, PolymorphicComponents, ExistentialQuantification , ScopedTypeVariables, ImplicitParams, FlexibleContexts , FlexibleInstances, EmptyDataDecls, CPP, BangPatterns , TypeSynonymInstances, TemplateHaskell, ForeignFunctionInterface , Arrows, Generics, NamedFieldPuns, PatternGuards , GeneralizedNewtypeDeriving, ExtensibleRecords, RestrictedTypeSynonyms , HereDocuments] ++ map DisableExtension [MonomorphismRestriction, ImplicitPrelude] ++ compatExtensionsExtra -- The extra known extensions in Cabal-1.2.3 vs Cabal-1.1.6 -- (Cabal-1.1.6 came with ghc-6.6. Cabal-1.2 came with ghc-6.8) compatExtensionsExtra = map EnableExtension [ KindSignatures, MagicHash, TypeFamilies, StandaloneDeriving , UnicodeSyntax, PatternSignatures, UnliftedFFITypes, LiberalTypeSynonyms , TypeOperators, RecordWildCards, RecordPuns, DisambiguateRecordFields , OverloadedStrings, GADTs, RelaxedPolyRec , ExtendedDefaultRules, UnboxedTuples, DeriveDataTypeable , ConstrainedClassMethods ] ++ map DisableExtension [MonoPatBinds] -- | A variation on the normal 'Text' instance, shows any ()'s in the original -- textual syntax. We need to show these otherwise it's confusing to users when -- we complain of their presence but do not pretty print them! -- displayRawVersionRange :: VersionRange -> String displayRawVersionRange = Disp.render . fst . foldVersionRange' -- precedence: -- All the same as the usual pretty printer, except for the parens ( Disp.text "-any" , 0 :: Int) (\v -> (Disp.text "==" <> disp v , 0)) (\v -> (Disp.char '>' <> disp v , 0)) (\v -> (Disp.char '<' <> disp v , 0)) (\v -> (Disp.text ">=" <> disp v , 0)) (\v -> (Disp.text "<=" <> disp v , 0)) (\v _ -> (Disp.text "==" <> dispWild v , 0)) (\(r1, p1) (r2, p2) -> (punct 2 p1 r1 <+> Disp.text "||" <+> punct 2 p2 r2 , 2)) (\(r1, p1) (r2, p2) -> (punct 1 p1 r1 <+> Disp.text "&&" <+> punct 1 p2 r2 , 1)) (\(r, _ ) -> (Disp.parens r, 0)) -- parens where dispWild (Version b _) = Disp.hcat (Disp.punctuate (Disp.char '.') (map Disp.int b)) <> Disp.text ".*" punct p p' | p < p' = Disp.parens | otherwise = id displayRawDependency :: Dependency -> String displayRawDependency (Dependency pkg vr) = display pkg ++ " " ++ displayRawVersionRange vr -- ------------------------------------------------------------ -- * Checks on the GenericPackageDescription -- ------------------------------------------------------------ -- | Check the build-depends fields for any weirdness or bad practise. -- checkPackageVersions :: GenericPackageDescription -> [PackageCheck] checkPackageVersions pkg = catMaybes [ -- Check that the version of base is bounded above. -- For example this bans "build-depends: base >= 3". -- It should probably be "build-depends: base >= 3 && < 4" -- which is the same as "build-depends: base == 3.*" check (not (boundedAbove baseDependency)) $ PackageDistInexcusable $ "The dependency 'build-depends: base' does not specify an upper " ++ "bound on the version number. Each major release of the 'base' " ++ "package changes the API in various ways and most packages will " ++ "need some changes to compile with it. The recommended practise " ++ "is to specify an upper bound on the version of the 'base' " ++ "package. This ensures your package will continue to build when a " ++ "new major version of the 'base' package is released. If you are " ++ "not sure what upper bound to use then use the next major " ++ "version. For example if you have tested your package with 'base' " ++ "version 2 and 3 then use 'build-depends: base >= 2 && < 4'." ] where -- TODO: What we really want to do is test if there exists any -- configuration in which the base version is unbounded above. -- However that's a bit tricky because there are many possible -- configurations. As a cheap easy and safe approximation we will -- pick a single "typical" configuration and check if that has an -- open upper bound. To get a typical configuration we finalise -- using no package index and the current platform. finalised = finalizePackageDescription [] (const True) buildPlatform (unknownCompilerInfo (CompilerId buildCompilerFlavor (Version [] [])) NoAbiTag) [] pkg baseDependency = case finalised of Right (pkg', _) | not (null baseDeps) -> foldr intersectVersionRanges anyVersion baseDeps where baseDeps = [ vr | Dependency (PackageName "base") vr <- buildDepends pkg' ] -- Just in case finalizePackageDescription fails for any reason, -- or if the package doesn't depend on the base package at all, -- then we will just skip the check, since boundedAbove noVersion = True _ -> noVersion boundedAbove :: VersionRange -> Bool boundedAbove vr = case asVersionIntervals vr of [] -> True -- this is the inconsistent version range. intervals -> case last intervals of (_, UpperBound _ _) -> True (_, NoUpperBound ) -> False checkConditionals :: GenericPackageDescription -> [PackageCheck] checkConditionals pkg = catMaybes [ check (not $ null unknownOSs) $ PackageDistInexcusable $ "Unknown operating system name " ++ commaSep (map quote unknownOSs) , check (not $ null unknownArches) $ PackageDistInexcusable $ "Unknown architecture name " ++ commaSep (map quote unknownArches) , check (not $ null unknownImpls) $ PackageDistInexcusable $ "Unknown compiler name " ++ commaSep (map quote unknownImpls) ] where unknownOSs = [ os | OS (OtherOS os) <- conditions ] unknownArches = [ arch | Arch (OtherArch arch) <- conditions ] unknownImpls = [ impl | Impl (OtherCompiler impl) _ <- conditions ] conditions = maybe [] freeVars (condLibrary pkg) ++ concatMap (freeVars . snd) (condExecutables pkg) freeVars (CondNode _ _ ifs) = concatMap compfv ifs compfv (c, ct, mct) = condfv c ++ freeVars ct ++ maybe [] freeVars mct condfv c = case c of Var v -> [v] Lit _ -> [] CNot c1 -> condfv c1 COr c1 c2 -> condfv c1 ++ condfv c2 CAnd c1 c2 -> condfv c1 ++ condfv c2 -- ------------------------------------------------------------ -- * Checks involving files in the package -- ------------------------------------------------------------ -- | Sanity check things that requires IO. It looks at the files in the -- package and expects to find the package unpacked in at the given file path. -- checkPackageFiles :: PackageDescription -> FilePath -> IO [PackageCheck] checkPackageFiles pkg root = checkPackageContent checkFilesIO pkg where checkFilesIO = CheckPackageContentOps { doesFileExist = System.doesFileExist . relative, doesDirectoryExist = System.doesDirectoryExist . relative } relative path = root path -- | A record of operations needed to check the contents of packages. -- Used by 'checkPackageContent'. -- data CheckPackageContentOps m = CheckPackageContentOps { doesFileExist :: FilePath -> m Bool, doesDirectoryExist :: FilePath -> m Bool } -- | Sanity check things that requires looking at files in the package. -- This is a generalised version of 'checkPackageFiles' that can work in any -- monad for which you can provide 'CheckPackageContentOps' operations. -- -- The point of this extra generality is to allow doing checks in some virtual -- file system, for example a tarball in memory. -- checkPackageContent :: Monad m => CheckPackageContentOps m -> PackageDescription -> m [PackageCheck] checkPackageContent ops pkg = do licenseErrors <- checkLicensesExist ops pkg setupError <- checkSetupExists ops pkg configureError <- checkConfigureExists ops pkg localPathErrors <- checkLocalPathsExist ops pkg vcsLocation <- checkMissingVcsInfo ops pkg return $ licenseErrors ++ catMaybes [setupError, configureError] ++ localPathErrors ++ vcsLocation checkLicensesExist :: Monad m => CheckPackageContentOps m -> PackageDescription -> m [PackageCheck] checkLicensesExist ops pkg = do exists <- mapM (doesFileExist ops) (licenseFiles pkg) return [ PackageBuildWarning $ "The '" ++ fieldname ++ "' field refers to the file " ++ quote file ++ " which does not exist." | (file, False) <- zip (licenseFiles pkg) exists ] where fieldname | length (licenseFiles pkg) == 1 = "license-file" | otherwise = "license-files" checkSetupExists :: Monad m => CheckPackageContentOps m -> PackageDescription -> m (Maybe PackageCheck) checkSetupExists ops _ = do hsexists <- doesFileExist ops "Setup.hs" lhsexists <- doesFileExist ops "Setup.lhs" return $ check (not hsexists && not lhsexists) $ PackageDistInexcusable $ "The package is missing a Setup.hs or Setup.lhs script." checkConfigureExists :: Monad m => CheckPackageContentOps m -> PackageDescription -> m (Maybe PackageCheck) checkConfigureExists ops PackageDescription { buildType = Just Configure } = do exists <- doesFileExist ops "configure" return $ check (not exists) $ PackageBuildWarning $ "The 'build-type' is 'Configure' but there is no 'configure' script. " ++ "You probably need to run 'autoreconf -i' to generate it." checkConfigureExists _ _ = return Nothing checkLocalPathsExist :: Monad m => CheckPackageContentOps m -> PackageDescription -> m [PackageCheck] checkLocalPathsExist ops pkg = do let dirs = [ (dir, kind) | bi <- allBuildInfo pkg , (dir, kind) <- [ (dir, "extra-lib-dirs") | dir <- extraLibDirs bi ] ++ [ (dir, "include-dirs") | dir <- includeDirs bi ] ++ [ (dir, "hs-source-dirs") | dir <- hsSourceDirs bi ] , isRelative dir ] missing <- filterM (liftM not . doesDirectoryExist ops . fst) dirs return [ PackageBuildWarning { explanation = quote (kind ++ ": " ++ dir) ++ " directory does not exist." } | (dir, kind) <- missing ] checkMissingVcsInfo :: Monad m => CheckPackageContentOps m -> PackageDescription -> m [PackageCheck] checkMissingVcsInfo ops pkg | null (sourceRepos pkg) = do vcsInUse <- liftM or $ mapM (doesDirectoryExist ops) repoDirnames if vcsInUse then return [ PackageDistSuspicious message ] else return [] where repoDirnames = [ dirname | repo <- knownRepoTypes , dirname <- repoTypeDirname repo ] message = "When distributing packages it is encouraged to specify source " ++ "control information in the .cabal file using one or more " ++ "'source-repository' sections. See the Cabal user guide for " ++ "details." checkMissingVcsInfo _ _ = return [] repoTypeDirname :: RepoType -> [FilePath] repoTypeDirname Darcs = ["_darcs"] repoTypeDirname Git = [".git"] repoTypeDirname SVN = [".svn"] repoTypeDirname CVS = ["CVS"] repoTypeDirname Mercurial = [".hg"] repoTypeDirname GnuArch = [".arch-params"] repoTypeDirname Bazaar = [".bzr"] repoTypeDirname Monotone = ["_MTN"] repoTypeDirname _ = [] -- ------------------------------------------------------------ -- * Checks involving files in the package -- ------------------------------------------------------------ -- | Check the names of all files in a package for portability problems. This -- should be done for example when creating or validating a package tarball. -- checkPackageFileNames :: [FilePath] -> [PackageCheck] checkPackageFileNames files = (take 1 . catMaybes . map checkWindowsPath $ files) ++ (take 1 . catMaybes . map checkTarPath $ files) -- If we get any of these checks triggering then we're likely to get -- many, and that's probably not helpful, so return at most one. checkWindowsPath :: FilePath -> Maybe PackageCheck checkWindowsPath path = check (not $ FilePath.Windows.isValid path') $ PackageDistInexcusable $ "Unfortunately, the file " ++ quote path ++ " is not a valid file " ++ "name on Windows which would cause portability problems for this " ++ "package. Windows file names cannot contain any of the characters " ++ "\":*?<>|\" and there are a few reserved names including \"aux\", " ++ "\"nul\", \"con\", \"prn\", \"com1-9\", \"lpt1-9\" and \"clock$\"." where path' = ".\\" ++ path -- force a relative name to catch invalid file names like "f:oo" which -- otherwise parse as file "oo" in the current directory on the 'f' drive. -- | Check a file name is valid for the portable POSIX tar format. -- -- The POSIX tar format has a restriction on the length of file names. It is -- unfortunately not a simple restriction like a maximum length. The exact -- restriction is that either the whole path be 100 characters or less, or it -- be possible to split the path on a directory separator such that the first -- part is 155 characters or less and the second part 100 characters or less. -- checkTarPath :: FilePath -> Maybe PackageCheck checkTarPath path | length path > 255 = Just longPath | otherwise = case pack nameMax (reverse (splitPath path)) of Left err -> Just err Right [] -> Nothing Right (first:rest) -> case pack prefixMax remainder of Left err -> Just err Right [] -> Nothing Right (_:_) -> Just noSplit where -- drop the '/' between the name and prefix: remainder = init first : rest where nameMax, prefixMax :: Int nameMax = 100 prefixMax = 155 pack _ [] = Left emptyName pack maxLen (c:cs) | n > maxLen = Left longName | otherwise = Right (pack' maxLen n cs) where n = length c pack' maxLen n (c:cs) | n' <= maxLen = pack' maxLen n' cs where n' = n + length c pack' _ _ cs = cs longPath = PackageDistInexcusable $ "The following file name is too long to store in a portable POSIX " ++ "format tar archive. The maximum length is 255 ASCII characters.\n" ++ "The file in question is:\n " ++ path longName = PackageDistInexcusable $ "The following file name is too long to store in a portable POSIX " ++ "format tar archive. The maximum length for the name part (including " ++ "extension) is 100 ASCII characters. The maximum length for any " ++ "individual directory component is 155.\n" ++ "The file in question is:\n " ++ path noSplit = PackageDistInexcusable $ "The following file name is too long to store in a portable POSIX " ++ "format tar archive. While the total length is less than 255 ASCII " ++ "characters, there are unfortunately further restrictions. It has to " ++ "be possible to split the file path on a directory separator into " ++ "two parts such that the first part fits in 155 characters or less " ++ "and the second part fits in 100 characters or less. Basically you " ++ "have to make the file name or directory names shorter, or you could " ++ "split a long directory name into nested subdirectories with shorter " ++ "names.\nThe file in question is:\n " ++ path emptyName = PackageDistInexcusable $ "Encountered a file with an empty name, something is very wrong! " ++ "Files with an empty name cannot be stored in a tar archive or in " ++ "standard file systems." -- ------------------------------------------------------------ -- * Utils -- ------------------------------------------------------------ quote :: String -> String quote s = "'" ++ s ++ "'" commaSep :: [String] -> String commaSep = intercalate ", " dups :: Ord a => [a] -> [a] dups xs = [ x | (x:_:_) <- group (sort xs) ] fileExtensionSupportedLanguage :: FilePath -> Bool fileExtensionSupportedLanguage path = isHaskell || isC where extension = takeExtension path isHaskell = extension `elem` [".hs", ".lhs"] isC = isJust (filenameCDialect extension) Cabal-1.22.5.0/Distribution/PackageDescription/Configuration.hs0000644000000000000000000006367112627136220022526 0ustar0000000000000000{-# LANGUAGE CPP #-} -- -fno-warn-deprecations for use of Map.foldWithKey {-# OPTIONS_GHC -fno-warn-deprecations #-} ----------------------------------------------------------------------------- -- | -- Module : Distribution.PackageDescription.Configuration -- Copyright : Thomas Schilling, 2007 -- License : BSD3 -- -- Maintainer : cabal-devel@haskell.org -- Portability : portable -- -- This is about the cabal configurations feature. It exports -- 'finalizePackageDescription' and 'flattenPackageDescription' which are -- functions for converting 'GenericPackageDescription's down to -- 'PackageDescription's. It has code for working with the tree of conditions -- and resolving or flattening conditions. module Distribution.PackageDescription.Configuration ( finalizePackageDescription, flattenPackageDescription, -- Utils parseCondition, freeVars, mapCondTree, mapTreeData, mapTreeConds, mapTreeConstrs, ) where import Distribution.Package ( PackageName, Dependency(..) ) import Distribution.PackageDescription ( GenericPackageDescription(..), PackageDescription(..) , Library(..), Executable(..), BuildInfo(..) , Flag(..), FlagName(..), FlagAssignment , Benchmark(..), CondTree(..), ConfVar(..), Condition(..) , TestSuite(..) ) import Distribution.PackageDescription.Utils ( cabalBug, userBug ) import Distribution.Version ( VersionRange, anyVersion, intersectVersionRanges, withinRange ) import Distribution.Compiler ( CompilerId(CompilerId) ) import Distribution.System ( Platform(..), OS, Arch ) import Distribution.Simple.Utils ( currentDir, lowercase ) import Distribution.Simple.Compiler ( CompilerInfo(..) ) import Distribution.Text ( Text(parse) ) import Distribution.Compat.ReadP as ReadP hiding ( char ) import Control.Arrow (first) import qualified Distribution.Compat.ReadP as ReadP ( char ) import Data.Char ( isAlphaNum ) import Data.Maybe ( catMaybes, maybeToList ) import Data.Map ( Map, fromListWith, toList ) import qualified Data.Map as Map #if __GLASGOW_HASKELL__ < 710 import Data.Monoid #endif ------------------------------------------------------------------------------ -- | Simplify the condition and return its free variables. simplifyCondition :: Condition c -> (c -> Either d Bool) -- ^ (partial) variable assignment -> (Condition d, [d]) simplifyCondition cond i = fv . walk $ cond where walk cnd = case cnd of Var v -> either Var Lit (i v) Lit b -> Lit b CNot c -> case walk c of Lit True -> Lit False Lit False -> Lit True c' -> CNot c' COr c d -> case (walk c, walk d) of (Lit False, d') -> d' (Lit True, _) -> Lit True (c', Lit False) -> c' (_, Lit True) -> Lit True (c',d') -> COr c' d' CAnd c d -> case (walk c, walk d) of (Lit False, _) -> Lit False (Lit True, d') -> d' (_, Lit False) -> Lit False (c', Lit True) -> c' (c',d') -> CAnd c' d' -- gather free vars fv c = (c, fv' c) fv' c = case c of Var v -> [v] Lit _ -> [] CNot c' -> fv' c' COr c1 c2 -> fv' c1 ++ fv' c2 CAnd c1 c2 -> fv' c1 ++ fv' c2 -- | Simplify a configuration condition using the OS and arch names. Returns -- the names of all the flags occurring in the condition. simplifyWithSysParams :: OS -> Arch -> CompilerInfo -> Condition ConfVar -> (Condition FlagName, [FlagName]) simplifyWithSysParams os arch cinfo cond = (cond', flags) where (cond', flags) = simplifyCondition cond interp interp (OS os') = Right $ os' == os interp (Arch arch') = Right $ arch' == arch interp (Impl comp vr) | matchImpl (compilerInfoId cinfo) = Right True | otherwise = case compilerInfoCompat cinfo of -- fixme: treat Nothing as unknown, rather than empty list once we -- support partial resolution of system parameters Nothing -> Right False Just compat -> Right (any matchImpl compat) where matchImpl (CompilerId c v) = comp == c && v `withinRange` vr interp (Flag f) = Left f -- TODO: Add instances and check -- -- prop_sC_idempotent cond a o = cond' == cond'' -- where -- cond' = simplifyCondition cond a o -- cond'' = simplifyCondition cond' a o -- -- prop_sC_noLits cond a o = isLit res || not (hasLits res) -- where -- res = simplifyCondition cond a o -- hasLits (Lit _) = True -- hasLits (CNot c) = hasLits c -- hasLits (COr l r) = hasLits l || hasLits r -- hasLits (CAnd l r) = hasLits l || hasLits r -- hasLits _ = False -- -- | Parse a configuration condition from a string. parseCondition :: ReadP r (Condition ConfVar) parseCondition = condOr where condOr = sepBy1 condAnd (oper "||") >>= return . foldl1 COr condAnd = sepBy1 cond (oper "&&")>>= return . foldl1 CAnd cond = sp >> (boolLiteral +++ inparens condOr +++ notCond +++ osCond +++ archCond +++ flagCond +++ implCond ) inparens = between (ReadP.char '(' >> sp) (sp >> ReadP.char ')' >> sp) notCond = ReadP.char '!' >> sp >> cond >>= return . CNot osCond = string "os" >> sp >> inparens osIdent >>= return . Var archCond = string "arch" >> sp >> inparens archIdent >>= return . Var flagCond = string "flag" >> sp >> inparens flagIdent >>= return . Var implCond = string "impl" >> sp >> inparens implIdent >>= return . Var boolLiteral = fmap Lit parse archIdent = fmap Arch parse osIdent = fmap OS parse flagIdent = fmap (Flag . FlagName . lowercase) (munch1 isIdentChar) isIdentChar c = isAlphaNum c || c == '_' || c == '-' oper s = sp >> string s >> sp sp = skipSpaces implIdent = do i <- parse vr <- sp >> option anyVersion parse return $ Impl i vr ------------------------------------------------------------------------------ mapCondTree :: (a -> b) -> (c -> d) -> (Condition v -> Condition w) -> CondTree v c a -> CondTree w d b mapCondTree fa fc fcnd (CondNode a c ifs) = CondNode (fa a) (fc c) (map g ifs) where g (cnd, t, me) = (fcnd cnd, mapCondTree fa fc fcnd t, fmap (mapCondTree fa fc fcnd) me) mapTreeConstrs :: (c -> d) -> CondTree v c a -> CondTree v d a mapTreeConstrs f = mapCondTree id f id mapTreeConds :: (Condition v -> Condition w) -> CondTree v c a -> CondTree w c a mapTreeConds f = mapCondTree id id f mapTreeData :: (a -> b) -> CondTree v c a -> CondTree v c b mapTreeData f = mapCondTree f id id -- | Result of dependency test. Isomorphic to @Maybe d@ but renamed for -- clarity. data DepTestRslt d = DepOk | MissingDeps d instance Monoid d => Monoid (DepTestRslt d) where mempty = DepOk mappend DepOk x = x mappend x DepOk = x mappend (MissingDeps d) (MissingDeps d') = MissingDeps (d `mappend` d') data BT a = BTN a | BTB (BT a) (BT a) -- very simple binary tree -- | Try to find a flag assignment that satisfies the constraints of all trees. -- -- Returns either the missing dependencies, or a tuple containing the -- resulting data, the associated dependencies, and the chosen flag -- assignments. -- -- In case of failure, the _smallest_ number of of missing dependencies is -- returned. [TODO: Could also be specified with a function argument.] -- -- TODO: The current algorithm is rather naive. A better approach would be to: -- -- * Rule out possible paths, by taking a look at the associated dependencies. -- -- * Infer the required values for the conditions of these paths, and -- calculate the required domains for the variables used in these -- conditions. Then picking a flag assignment would be linear (I guess). -- -- This would require some sort of SAT solving, though, thus it's not -- implemented unless we really need it. -- resolveWithFlags :: [(FlagName,[Bool])] -- ^ Domain for each flag name, will be tested in order. -> OS -- ^ OS as returned by Distribution.System.buildOS -> Arch -- ^ Arch as returned by Distribution.System.buildArch -> CompilerInfo -- ^ Compiler information -> [Dependency] -- ^ Additional constraints -> [CondTree ConfVar [Dependency] PDTagged] -> ([Dependency] -> DepTestRslt [Dependency]) -- ^ Dependency test function. -> Either [Dependency] (TargetSet PDTagged, FlagAssignment) -- ^ Either the missing dependencies (error case), or a pair of -- (set of build targets with dependencies, chosen flag assignments) resolveWithFlags dom os arch impl constrs trees checkDeps = case try dom [] of Right r -> Right r Left dbt -> Left $ findShortest dbt where extraConstrs = toDepMap constrs -- simplify trees by (partially) evaluating all conditions and converting -- dependencies to dependency maps. simplifiedTrees = map ( mapTreeConstrs toDepMap -- convert to maps . mapTreeConds (fst . simplifyWithSysParams os arch impl)) trees -- @try@ recursively tries all possible flag assignments in the domain and -- either succeeds or returns a binary tree with the missing dependencies -- encountered in each run. Since the tree is constructed lazily, we -- avoid some computation overhead in the successful case. try [] flags = let targetSet = TargetSet $ flip map simplifiedTrees $ -- apply additional constraints to all dependencies first (`constrainBy` extraConstrs) . simplifyCondTree (env flags) deps = overallDependencies targetSet in case checkDeps (fromDepMap deps) of DepOk -> Right (targetSet, flags) MissingDeps mds -> Left (BTN mds) try ((n, vals):rest) flags = tryAll $ map (\v -> try rest ((n, v):flags)) vals tryAll = foldr mp mz -- special version of `mplus' for our local purposes mp (Left xs) (Left ys) = (Left (BTB xs ys)) mp (Left _) m@(Right _) = m mp m@(Right _) _ = m -- `mzero' mz = Left (BTN []) env flags flag = (maybe (Left flag) Right . lookup flag) flags -- for the error case we inspect our lazy tree of missing dependencies and -- pick the shortest list of missing dependencies findShortest (BTN x) = x findShortest (BTB lt rt) = let l = findShortest lt r = findShortest rt in case (l,r) of ([], xs) -> xs -- [] is too short (xs, []) -> xs ([x], _) -> [x] -- single elem is optimum (_, [x]) -> [x] (xs, ys) -> if lazyLengthCmp xs ys then xs else ys -- lazy variant of @\xs ys -> length xs <= length ys@ lazyLengthCmp [] _ = True lazyLengthCmp _ [] = False lazyLengthCmp (_:xs) (_:ys) = lazyLengthCmp xs ys -- | A map of dependencies. Newtyped since the default monoid instance is not -- appropriate. The monoid instance uses 'intersectVersionRanges'. newtype DependencyMap = DependencyMap { unDependencyMap :: Map PackageName VersionRange } deriving (Show, Read) instance Monoid DependencyMap where mempty = DependencyMap Map.empty (DependencyMap a) `mappend` (DependencyMap b) = DependencyMap (Map.unionWith intersectVersionRanges a b) toDepMap :: [Dependency] -> DependencyMap toDepMap ds = DependencyMap $ fromListWith intersectVersionRanges [ (p,vr) | Dependency p vr <- ds ] fromDepMap :: DependencyMap -> [Dependency] fromDepMap m = [ Dependency p vr | (p,vr) <- toList (unDependencyMap m) ] simplifyCondTree :: (Monoid a, Monoid d) => (v -> Either v Bool) -> CondTree v d a -> (d, a) simplifyCondTree env (CondNode a d ifs) = mconcat $ (d, a) : catMaybes (map simplifyIf ifs) where simplifyIf (cnd, t, me) = case simplifyCondition cnd env of (Lit True, _) -> Just $ simplifyCondTree env t (Lit False, _) -> fmap (simplifyCondTree env) me _ -> error $ "Environment not defined for all free vars" -- | Flatten a CondTree. This will resolve the CondTree by taking all -- possible paths into account. Note that since branches represent exclusive -- choices this may not result in a \"sane\" result. ignoreConditions :: (Monoid a, Monoid c) => CondTree v c a -> (a, c) ignoreConditions (CondNode a c ifs) = (a, c) `mappend` mconcat (concatMap f ifs) where f (_, t, me) = ignoreConditions t : maybeToList (fmap ignoreConditions me) freeVars :: CondTree ConfVar c a -> [FlagName] freeVars t = [ f | Flag f <- freeVars' t ] where freeVars' (CondNode _ _ ifs) = concatMap compfv ifs compfv (c, ct, mct) = condfv c ++ freeVars' ct ++ maybe [] freeVars' mct condfv c = case c of Var v -> [v] Lit _ -> [] CNot c' -> condfv c' COr c1 c2 -> condfv c1 ++ condfv c2 CAnd c1 c2 -> condfv c1 ++ condfv c2 ------------------------------------------------------------------------------ -- | A set of targets with their package dependencies newtype TargetSet a = TargetSet [(DependencyMap, a)] -- | Combine the target-specific dependencies in a TargetSet to give the -- dependencies for the package as a whole. overallDependencies :: TargetSet PDTagged -> DependencyMap overallDependencies (TargetSet targets) = mconcat depss where (depss, _) = unzip $ filter (removeDisabledSections . snd) targets removeDisabledSections :: PDTagged -> Bool removeDisabledSections (Lib _) = True removeDisabledSections (Exe _ _) = True removeDisabledSections (Test _ t) = testEnabled t removeDisabledSections (Bench _ b) = benchmarkEnabled b removeDisabledSections PDNull = True -- Apply extra constraints to a dependency map. -- Combines dependencies where the result will only contain keys from the left -- (first) map. If a key also exists in the right map, both constraints will -- be intersected. constrainBy :: DependencyMap -- ^ Input map -> DependencyMap -- ^ Extra constraints -> DependencyMap constrainBy left extra = DependencyMap $ Map.foldWithKey tightenConstraint (unDependencyMap left) (unDependencyMap extra) where tightenConstraint n c l = case Map.lookup n l of Nothing -> l Just vr -> Map.insert n (intersectVersionRanges vr c) l -- | Collect up the targets in a TargetSet of tagged targets, storing the -- dependencies as we go. flattenTaggedTargets :: TargetSet PDTagged -> (Maybe Library, [(String, Executable)], [(String, TestSuite)] , [(String, Benchmark)]) flattenTaggedTargets (TargetSet targets) = foldr untag (Nothing, [], [], []) targets where untag (_, Lib _) (Just _, _, _, _) = userBug "Only one library expected" untag (deps, Lib l) (Nothing, exes, tests, bms) = (Just l', exes, tests, bms) where l' = l { libBuildInfo = (libBuildInfo l) { targetBuildDepends = fromDepMap deps } } untag (deps, Exe n e) (mlib, exes, tests, bms) | any ((== n) . fst) exes = userBug $ "There exist several exes with the same name: '" ++ n ++ "'" | any ((== n) . fst) tests = userBug $ "There exists a test with the same name as an exe: '" ++ n ++ "'" | any ((== n) . fst) bms = userBug $ "There exists a benchmark with the same name as an exe: '" ++ n ++ "'" | otherwise = (mlib, (n, e'):exes, tests, bms) where e' = e { buildInfo = (buildInfo e) { targetBuildDepends = fromDepMap deps } } untag (deps, Test n t) (mlib, exes, tests, bms) | any ((== n) . fst) tests = userBug $ "There exist several tests with the same name: '" ++ n ++ "'" | any ((== n) . fst) exes = userBug $ "There exists an exe with the same name as the test: '" ++ n ++ "'" | any ((== n) . fst) bms = userBug $ "There exists a benchmark with the same name as the test: '" ++ n ++ "'" | otherwise = (mlib, exes, (n, t'):tests, bms) where t' = t { testBuildInfo = (testBuildInfo t) { targetBuildDepends = fromDepMap deps } } untag (deps, Bench n b) (mlib, exes, tests, bms) | any ((== n) . fst) bms = userBug $ "There exist several benchmarks with the same name: '" ++ n ++ "'" | any ((== n) . fst) exes = userBug $ "There exists an exe with the same name as the benchmark: '" ++ n ++ "'" | any ((== n) . fst) tests = userBug $ "There exists a test with the same name as the benchmark: '" ++ n ++ "'" | otherwise = (mlib, exes, tests, (n, b'):bms) where b' = b { benchmarkBuildInfo = (benchmarkBuildInfo b) { targetBuildDepends = fromDepMap deps } } untag (_, PDNull) x = x -- actually this should not happen, but let's be liberal ------------------------------------------------------------------------------ -- Convert GenericPackageDescription to PackageDescription -- data PDTagged = Lib Library | Exe String Executable | Test String TestSuite | Bench String Benchmark | PDNull deriving Show instance Monoid PDTagged where mempty = PDNull PDNull `mappend` x = x x `mappend` PDNull = x Lib l `mappend` Lib l' = Lib (l `mappend` l') Exe n e `mappend` Exe n' e' | n == n' = Exe n (e `mappend` e') Test n t `mappend` Test n' t' | n == n' = Test n (t `mappend` t') Bench n b `mappend` Bench n' b' | n == n' = Bench n (b `mappend` b') _ `mappend` _ = cabalBug "Cannot combine incompatible tags" -- | Create a package description with all configurations resolved. -- -- This function takes a `GenericPackageDescription` and several environment -- parameters and tries to generate `PackageDescription` by finding a flag -- assignment that result in satisfiable dependencies. -- -- It takes as inputs a not necessarily complete specifications of flags -- assignments, an optional package index as well as platform parameters. If -- some flags are not assigned explicitly, this function will try to pick an -- assignment that causes this function to succeed. The package index is -- optional since on some platforms we cannot determine which packages have -- been installed before. When no package index is supplied, every dependency -- is assumed to be satisfiable, therefore all not explicitly assigned flags -- will get their default values. -- -- This function will fail if it cannot find a flag assignment that leads to -- satisfiable dependencies. (It will not try alternative assignments for -- explicitly specified flags.) In case of failure it will return a /minimum/ -- number of dependencies that could not be satisfied. On success, it will -- return the package description and the full flag assignment chosen. -- finalizePackageDescription :: FlagAssignment -- ^ Explicitly specified flag assignments -> (Dependency -> Bool) -- ^ Is a given dependency satisfiable from the set of -- available packages? If this is unknown then use -- True. -> Platform -- ^ The 'Arch' and 'OS' -> CompilerInfo -- ^ Compiler information -> [Dependency] -- ^ Additional constraints -> GenericPackageDescription -> Either [Dependency] (PackageDescription, FlagAssignment) -- ^ Either missing dependencies or the resolved package -- description along with the flag assignments chosen. finalizePackageDescription userflags satisfyDep (Platform arch os) impl constraints (GenericPackageDescription pkg flags mlib0 exes0 tests0 bms0) = case resolveFlags of Right ((mlib, exes', tests', bms'), targetSet, flagVals) -> Right ( pkg { library = mlib , executables = exes' , testSuites = tests' , benchmarks = bms' , buildDepends = fromDepMap (overallDependencies targetSet) --TODO: we need to find a way to avoid pulling in deps -- for non-buildable components. However cannot simply -- filter at this stage, since if the package were not -- available we would have failed already. } , flagVals ) Left missing -> Left missing where -- Combine lib, exes, and tests into one list of @CondTree@s with tagged data condTrees = maybeToList (fmap (mapTreeData Lib) mlib0 ) ++ map (\(name,tree) -> mapTreeData (Exe name) tree) exes0 ++ map (\(name,tree) -> mapTreeData (Test name) tree) tests0 ++ map (\(name,tree) -> mapTreeData (Bench name) tree) bms0 resolveFlags = case resolveWithFlags flagChoices os arch impl constraints condTrees check of Right (targetSet, fs) -> let (mlib, exes, tests, bms) = flattenTaggedTargets targetSet in Right ( (fmap libFillInDefaults mlib, map (\(n,e) -> (exeFillInDefaults e) { exeName = n }) exes, map (\(n,t) -> (testFillInDefaults t) { testName = n }) tests, map (\(n,b) -> (benchFillInDefaults b) { benchmarkName = n }) bms), targetSet, fs) Left missing -> Left missing flagChoices = map (\(MkFlag n _ d manual) -> (n, d2c manual n d)) flags d2c manual n b = case lookup n userflags of Just val -> [val] Nothing | manual -> [b] | otherwise -> [b, not b] --flagDefaults = map (\(n,x:_) -> (n,x)) flagChoices check ds = let missingDeps = filter (not . satisfyDep) ds in if null missingDeps then DepOk else MissingDeps missingDeps {- let tst_p = (CondNode [1::Int] [Distribution.Package.Dependency "a" AnyVersion] []) let tst_p2 = (CondNode [1::Int] [Distribution.Package.Dependency "a" (EarlierVersion (Version [1,0] [])), Distribution.Package.Dependency "a" (LaterVersion (Version [2,0] []))] []) let p_index = Distribution.Simple.PackageIndex.fromList [Distribution.Package.PackageIdentifier "a" (Version [0,5] []), Distribution.Package.PackageIdentifier "a" (Version [2,5] [])] let look = not . null . Distribution.Simple.PackageIndex.lookupDependency p_index let looks ds = mconcat $ map (\d -> if look d then DepOk else MissingDeps [d]) ds resolveWithFlags [] Distribution.System.Linux Distribution.System.I386 (Distribution.Compiler.GHC,Version [6,8,2] []) [tst_p] looks ===> Right ... resolveWithFlags [] Distribution.System.Linux Distribution.System.I386 (Distribution.Compiler.GHC,Version [6,8,2] []) [tst_p2] looks ===> Left ... -} -- | Flatten a generic package description by ignoring all conditions and just -- join the field descriptors into on package description. Note, however, -- that this may lead to inconsistent field values, since all values are -- joined into one field, which may not be possible in the original package -- description, due to the use of exclusive choices (if ... else ...). -- -- TODO: One particularly tricky case is defaulting. In the original package -- description, e.g., the source directory might either be the default or a -- certain, explicitly set path. Since defaults are filled in only after the -- package has been resolved and when no explicit value has been set, the -- default path will be missing from the package description returned by this -- function. flattenPackageDescription :: GenericPackageDescription -> PackageDescription flattenPackageDescription (GenericPackageDescription pkg _ mlib0 exes0 tests0 bms0) = pkg { library = mlib , executables = reverse exes , testSuites = reverse tests , benchmarks = reverse bms , buildDepends = ldeps ++ reverse edeps ++ reverse tdeps ++ reverse bdeps } where (mlib, ldeps) = case mlib0 of Just lib -> let (l,ds) = ignoreConditions lib in (Just (libFillInDefaults l), ds) Nothing -> (Nothing, []) (exes, edeps) = foldr flattenExe ([],[]) exes0 (tests, tdeps) = foldr flattenTst ([],[]) tests0 (bms, bdeps) = foldr flattenBm ([],[]) bms0 flattenExe (n, t) (es, ds) = let (e, ds') = ignoreConditions t in ( (exeFillInDefaults $ e { exeName = n }) : es, ds' ++ ds ) flattenTst (n, t) (es, ds) = let (e, ds') = ignoreConditions t in ( (testFillInDefaults $ e { testName = n }) : es, ds' ++ ds ) flattenBm (n, t) (es, ds) = let (e, ds') = ignoreConditions t in ( (benchFillInDefaults $ e { benchmarkName = n }) : es, ds' ++ ds ) -- This is in fact rather a hack. The original version just overrode the -- default values, however, when adding conditions we had to switch to a -- modifier-based approach. There, nothing is ever overwritten, but only -- joined together. -- -- This is the cleanest way i could think of, that doesn't require -- changing all field parsing functions to return modifiers instead. libFillInDefaults :: Library -> Library libFillInDefaults lib@(Library { libBuildInfo = bi }) = lib { libBuildInfo = biFillInDefaults bi } exeFillInDefaults :: Executable -> Executable exeFillInDefaults exe@(Executable { buildInfo = bi }) = exe { buildInfo = biFillInDefaults bi } testFillInDefaults :: TestSuite -> TestSuite testFillInDefaults tst@(TestSuite { testBuildInfo = bi }) = tst { testBuildInfo = biFillInDefaults bi } benchFillInDefaults :: Benchmark -> Benchmark benchFillInDefaults bm@(Benchmark { benchmarkBuildInfo = bi }) = bm { benchmarkBuildInfo = biFillInDefaults bi } biFillInDefaults :: BuildInfo -> BuildInfo biFillInDefaults bi = if null (hsSourceDirs bi) then bi { hsSourceDirs = [currentDir] } else bi Cabal-1.22.5.0/Distribution/PackageDescription/Parse.hs0000644000000000000000000015273312627136220020767 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveDataTypeable #-} ----------------------------------------------------------------------------- -- | -- Module : Distribution.PackageDescription.Parse -- Copyright : Isaac Jones 2003-2005 -- License : BSD3 -- -- Maintainer : cabal-devel@haskell.org -- Portability : portable -- -- This defined parsers and partial pretty printers for the @.cabal@ format. -- Some of the complexity in this module is due to the fact that we have to be -- backwards compatible with old @.cabal@ files, so there's code to translate -- into the newer structure. module Distribution.PackageDescription.Parse ( -- * Package descriptions readPackageDescription, writePackageDescription, parsePackageDescription, showPackageDescription, -- ** Parsing ParseResult(..), FieldDescr(..), LineNo, -- ** Supplementary build information readHookedBuildInfo, parseHookedBuildInfo, writeHookedBuildInfo, showHookedBuildInfo, pkgDescrFieldDescrs, libFieldDescrs, executableFieldDescrs, binfoFieldDescrs, sourceRepoFieldDescrs, testSuiteFieldDescrs, flagFieldDescrs ) where import Data.Char (isSpace) import Data.Maybe (listToMaybe, isJust) #if __GLASGOW_HASKELL__ < 710 import Data.Monoid ( Monoid(..) ) #endif import Data.List (nub, unfoldr, partition, (\\)) import Control.Monad (liftM, foldM, when, unless, ap) #if __GLASGOW_HASKELL__ < 710 import Control.Applicative (Applicative(..)) #endif import Control.Arrow (first) import System.Directory (doesFileExist) import qualified Data.ByteString.Lazy.Char8 as BS.Char8 import Data.Typeable import Data.Data import qualified Data.Map as Map import Distribution.Text ( Text(disp, parse), display, simpleParse ) import Distribution.Compat.ReadP ((+++), option) import qualified Distribution.Compat.ReadP as Parse import Text.PrettyPrint import Distribution.ParseUtils hiding (parseFields) import Distribution.PackageDescription import Distribution.PackageDescription.Utils ( cabalBug, userBug ) import Distribution.Package ( PackageIdentifier(..), Dependency(..), packageName, packageVersion ) import Distribution.ModuleName ( ModuleName ) import Distribution.Version ( Version(Version), orLaterVersion , LowerBound(..), asVersionIntervals ) import Distribution.Verbosity (Verbosity) import Distribution.Compiler (CompilerFlavor(..)) import Distribution.PackageDescription.Configuration (parseCondition, freeVars) import Distribution.Simple.Utils ( die, dieWithLocation, warn, intercalate, lowercase, cabalVersion , withFileContents, withUTF8FileContents , writeFileAtomic, writeUTF8File ) -- ----------------------------------------------------------------------------- -- The PackageDescription type pkgDescrFieldDescrs :: [FieldDescr PackageDescription] pkgDescrFieldDescrs = [ simpleField "name" disp parse packageName (\name pkg -> pkg{package=(package pkg){pkgName=name}}) , simpleField "version" disp parse packageVersion (\ver pkg -> pkg{package=(package pkg){pkgVersion=ver}}) , simpleField "cabal-version" (either disp disp) (liftM Left parse +++ liftM Right parse) specVersionRaw (\v pkg -> pkg{specVersionRaw=v}) , simpleField "build-type" (maybe empty disp) (fmap Just parse) buildType (\t pkg -> pkg{buildType=t}) , simpleField "license" disp parseLicenseQ license (\l pkg -> pkg{license=l}) -- We have both 'license-file' and 'license-files' fields. -- Rather than declaring license-file to be deprecated, we will continue -- to allow both. The 'license-file' will continue to only allow single -- tokens, while 'license-files' allows multiple. On pretty-printing, we -- will use 'license-file' if there's just one, and use 'license-files' -- otherwise. , simpleField "license-file" showFilePath parseFilePathQ (\pkg -> case licenseFiles pkg of [x] -> x _ -> "") (\l pkg -> pkg{licenseFiles=licenseFiles pkg ++ [l]}) , listField "license-files" showFilePath parseFilePathQ (\pkg -> case licenseFiles pkg of [_] -> [] xs -> xs) (\ls pkg -> pkg{licenseFiles=ls}) , simpleField "copyright" showFreeText parseFreeText copyright (\val pkg -> pkg{copyright=val}) , simpleField "maintainer" showFreeText parseFreeText maintainer (\val pkg -> pkg{maintainer=val}) , simpleField "stability" showFreeText parseFreeText stability (\val pkg -> pkg{stability=val}) , simpleField "homepage" showFreeText parseFreeText homepage (\val pkg -> pkg{homepage=val}) , simpleField "package-url" showFreeText parseFreeText pkgUrl (\val pkg -> pkg{pkgUrl=val}) , simpleField "bug-reports" showFreeText parseFreeText bugReports (\val pkg -> pkg{bugReports=val}) , simpleField "synopsis" showFreeText parseFreeText synopsis (\val pkg -> pkg{synopsis=val}) , simpleField "description" showFreeText parseFreeText description (\val pkg -> pkg{description=val}) , simpleField "category" showFreeText parseFreeText category (\val pkg -> pkg{category=val}) , simpleField "author" showFreeText parseFreeText author (\val pkg -> pkg{author=val}) , listField "tested-with" showTestedWith parseTestedWithQ testedWith (\val pkg -> pkg{testedWith=val}) , listFieldWithSep vcat "data-files" showFilePath parseFilePathQ dataFiles (\val pkg -> pkg{dataFiles=val}) , simpleField "data-dir" showFilePath parseFilePathQ dataDir (\val pkg -> pkg{dataDir=val}) , listFieldWithSep vcat "extra-source-files" showFilePath parseFilePathQ extraSrcFiles (\val pkg -> pkg{extraSrcFiles=val}) , listFieldWithSep vcat "extra-tmp-files" showFilePath parseFilePathQ extraTmpFiles (\val pkg -> pkg{extraTmpFiles=val}) , listFieldWithSep vcat "extra-doc-files" showFilePath parseFilePathQ extraDocFiles (\val pkg -> pkg{extraDocFiles=val}) ] -- | Store any fields beginning with "x-" in the customFields field of -- a PackageDescription. All other fields will generate a warning. storeXFieldsPD :: UnrecFieldParser PackageDescription storeXFieldsPD (f@('x':'-':_),val) pkg = Just pkg{ customFieldsPD = customFieldsPD pkg ++ [(f,val)]} storeXFieldsPD _ _ = Nothing -- --------------------------------------------------------------------------- -- The Library type libFieldDescrs :: [FieldDescr Library] libFieldDescrs = [ listFieldWithSep vcat "exposed-modules" disp parseModuleNameQ exposedModules (\mods lib -> lib{exposedModules=mods}) , commaListFieldWithSep vcat "reexported-modules" disp parse reexportedModules (\mods lib -> lib{reexportedModules=mods}) , listFieldWithSep vcat "required-signatures" disp parseModuleNameQ requiredSignatures (\mods lib -> lib{requiredSignatures=mods}) , listFieldWithSep vcat "exposed-signatures" disp parseModuleNameQ exposedSignatures (\mods lib -> lib{exposedSignatures=mods}) , boolField "exposed" libExposed (\val lib -> lib{libExposed=val}) ] ++ map biToLib binfoFieldDescrs where biToLib = liftField libBuildInfo (\bi lib -> lib{libBuildInfo=bi}) storeXFieldsLib :: UnrecFieldParser Library storeXFieldsLib (f@('x':'-':_), val) l@(Library { libBuildInfo = bi }) = Just $ l {libBuildInfo = bi{ customFieldsBI = customFieldsBI bi ++ [(f,val)]}} storeXFieldsLib _ _ = Nothing -- --------------------------------------------------------------------------- -- The Executable type executableFieldDescrs :: [FieldDescr Executable] executableFieldDescrs = [ -- note ordering: configuration must come first, for -- showPackageDescription. simpleField "executable" showToken parseTokenQ exeName (\xs exe -> exe{exeName=xs}) , simpleField "main-is" showFilePath parseFilePathQ modulePath (\xs exe -> exe{modulePath=xs}) ] ++ map biToExe binfoFieldDescrs where biToExe = liftField buildInfo (\bi exe -> exe{buildInfo=bi}) storeXFieldsExe :: UnrecFieldParser Executable storeXFieldsExe (f@('x':'-':_), val) e@(Executable { buildInfo = bi }) = Just $ e {buildInfo = bi{ customFieldsBI = (f,val):customFieldsBI bi}} storeXFieldsExe _ _ = Nothing -- --------------------------------------------------------------------------- -- The TestSuite type -- | An intermediate type just used for parsing the test-suite stanza. -- After validation it is converted into the proper 'TestSuite' type. data TestSuiteStanza = TestSuiteStanza { testStanzaTestType :: Maybe TestType, testStanzaMainIs :: Maybe FilePath, testStanzaTestModule :: Maybe ModuleName, testStanzaBuildInfo :: BuildInfo } emptyTestStanza :: TestSuiteStanza emptyTestStanza = TestSuiteStanza Nothing Nothing Nothing mempty testSuiteFieldDescrs :: [FieldDescr TestSuiteStanza] testSuiteFieldDescrs = [ simpleField "type" (maybe empty disp) (fmap Just parse) testStanzaTestType (\x suite -> suite { testStanzaTestType = x }) , simpleField "main-is" (maybe empty showFilePath) (fmap Just parseFilePathQ) testStanzaMainIs (\x suite -> suite { testStanzaMainIs = x }) , simpleField "test-module" (maybe empty disp) (fmap Just parseModuleNameQ) testStanzaTestModule (\x suite -> suite { testStanzaTestModule = x }) ] ++ map biToTest binfoFieldDescrs where biToTest = liftField testStanzaBuildInfo (\bi suite -> suite { testStanzaBuildInfo = bi }) storeXFieldsTest :: UnrecFieldParser TestSuiteStanza storeXFieldsTest (f@('x':'-':_), val) t@(TestSuiteStanza { testStanzaBuildInfo = bi }) = Just $ t {testStanzaBuildInfo = bi{ customFieldsBI = (f,val):customFieldsBI bi}} storeXFieldsTest _ _ = Nothing validateTestSuite :: LineNo -> TestSuiteStanza -> ParseResult TestSuite validateTestSuite line stanza = case testStanzaTestType stanza of Nothing -> return $ emptyTestSuite { testBuildInfo = testStanzaBuildInfo stanza } Just tt@(TestTypeUnknown _ _) -> return emptyTestSuite { testInterface = TestSuiteUnsupported tt, testBuildInfo = testStanzaBuildInfo stanza } Just tt | tt `notElem` knownTestTypes -> return emptyTestSuite { testInterface = TestSuiteUnsupported tt, testBuildInfo = testStanzaBuildInfo stanza } Just tt@(TestTypeExe ver) -> case testStanzaMainIs stanza of Nothing -> syntaxError line (missingField "main-is" tt) Just file -> do when (isJust (testStanzaTestModule stanza)) $ warning (extraField "test-module" tt) return emptyTestSuite { testInterface = TestSuiteExeV10 ver file, testBuildInfo = testStanzaBuildInfo stanza } Just tt@(TestTypeLib ver) -> case testStanzaTestModule stanza of Nothing -> syntaxError line (missingField "test-module" tt) Just module_ -> do when (isJust (testStanzaMainIs stanza)) $ warning (extraField "main-is" tt) return emptyTestSuite { testInterface = TestSuiteLibV09 ver module_, testBuildInfo = testStanzaBuildInfo stanza } where missingField name tt = "The '" ++ name ++ "' field is required for the " ++ display tt ++ " test suite type." extraField name tt = "The '" ++ name ++ "' field is not used for the '" ++ display tt ++ "' test suite type." -- --------------------------------------------------------------------------- -- The Benchmark type -- | An intermediate type just used for parsing the benchmark stanza. -- After validation it is converted into the proper 'Benchmark' type. data BenchmarkStanza = BenchmarkStanza { benchmarkStanzaBenchmarkType :: Maybe BenchmarkType, benchmarkStanzaMainIs :: Maybe FilePath, benchmarkStanzaBenchmarkModule :: Maybe ModuleName, benchmarkStanzaBuildInfo :: BuildInfo } emptyBenchmarkStanza :: BenchmarkStanza emptyBenchmarkStanza = BenchmarkStanza Nothing Nothing Nothing mempty benchmarkFieldDescrs :: [FieldDescr BenchmarkStanza] benchmarkFieldDescrs = [ simpleField "type" (maybe empty disp) (fmap Just parse) benchmarkStanzaBenchmarkType (\x suite -> suite { benchmarkStanzaBenchmarkType = x }) , simpleField "main-is" (maybe empty showFilePath) (fmap Just parseFilePathQ) benchmarkStanzaMainIs (\x suite -> suite { benchmarkStanzaMainIs = x }) ] ++ map biToBenchmark binfoFieldDescrs where biToBenchmark = liftField benchmarkStanzaBuildInfo (\bi suite -> suite { benchmarkStanzaBuildInfo = bi }) storeXFieldsBenchmark :: UnrecFieldParser BenchmarkStanza storeXFieldsBenchmark (f@('x':'-':_), val) t@(BenchmarkStanza { benchmarkStanzaBuildInfo = bi }) = Just $ t {benchmarkStanzaBuildInfo = bi{ customFieldsBI = (f,val):customFieldsBI bi}} storeXFieldsBenchmark _ _ = Nothing validateBenchmark :: LineNo -> BenchmarkStanza -> ParseResult Benchmark validateBenchmark line stanza = case benchmarkStanzaBenchmarkType stanza of Nothing -> return $ emptyBenchmark { benchmarkBuildInfo = benchmarkStanzaBuildInfo stanza } Just tt@(BenchmarkTypeUnknown _ _) -> return emptyBenchmark { benchmarkInterface = BenchmarkUnsupported tt, benchmarkBuildInfo = benchmarkStanzaBuildInfo stanza } Just tt | tt `notElem` knownBenchmarkTypes -> return emptyBenchmark { benchmarkInterface = BenchmarkUnsupported tt, benchmarkBuildInfo = benchmarkStanzaBuildInfo stanza } Just tt@(BenchmarkTypeExe ver) -> case benchmarkStanzaMainIs stanza of Nothing -> syntaxError line (missingField "main-is" tt) Just file -> do when (isJust (benchmarkStanzaBenchmarkModule stanza)) $ warning (extraField "benchmark-module" tt) return emptyBenchmark { benchmarkInterface = BenchmarkExeV10 ver file, benchmarkBuildInfo = benchmarkStanzaBuildInfo stanza } where missingField name tt = "The '" ++ name ++ "' field is required for the " ++ display tt ++ " benchmark type." extraField name tt = "The '" ++ name ++ "' field is not used for the '" ++ display tt ++ "' benchmark type." -- --------------------------------------------------------------------------- -- The BuildInfo type binfoFieldDescrs :: [FieldDescr BuildInfo] binfoFieldDescrs = [ boolField "buildable" buildable (\val binfo -> binfo{buildable=val}) , commaListField "build-tools" disp parseBuildTool buildTools (\xs binfo -> binfo{buildTools=xs}) , commaListFieldWithSep vcat "build-depends" disp parse buildDependsWithRenaming setBuildDependsWithRenaming , spaceListField "cpp-options" showToken parseTokenQ' cppOptions (\val binfo -> binfo{cppOptions=val}) , spaceListField "cc-options" showToken parseTokenQ' ccOptions (\val binfo -> binfo{ccOptions=val}) , spaceListField "ld-options" showToken parseTokenQ' ldOptions (\val binfo -> binfo{ldOptions=val}) , commaListField "pkgconfig-depends" disp parsePkgconfigDependency pkgconfigDepends (\xs binfo -> binfo{pkgconfigDepends=xs}) , listField "frameworks" showToken parseTokenQ frameworks (\val binfo -> binfo{frameworks=val}) , listFieldWithSep vcat "c-sources" showFilePath parseFilePathQ cSources (\paths binfo -> binfo{cSources=paths}) , listFieldWithSep vcat "js-sources" showFilePath parseFilePathQ jsSources (\paths binfo -> binfo{jsSources=paths}) , simpleField "default-language" (maybe empty disp) (option Nothing (fmap Just parseLanguageQ)) defaultLanguage (\lang binfo -> binfo{defaultLanguage=lang}) , listField "other-languages" disp parseLanguageQ otherLanguages (\langs binfo -> binfo{otherLanguages=langs}) , listField "default-extensions" disp parseExtensionQ defaultExtensions (\exts binfo -> binfo{defaultExtensions=exts}) , listField "other-extensions" disp parseExtensionQ otherExtensions (\exts binfo -> binfo{otherExtensions=exts}) , listField "extensions" disp parseExtensionQ oldExtensions (\exts binfo -> binfo{oldExtensions=exts}) , listFieldWithSep vcat "extra-libraries" showToken parseTokenQ extraLibs (\xs binfo -> binfo{extraLibs=xs}) , listFieldWithSep vcat "extra-ghci-libraries" showToken parseTokenQ extraGHCiLibs (\xs binfo -> binfo{extraGHCiLibs=xs}) , listField "extra-lib-dirs" showFilePath parseFilePathQ extraLibDirs (\xs binfo -> binfo{extraLibDirs=xs}) , listFieldWithSep vcat "includes" showFilePath parseFilePathQ includes (\paths binfo -> binfo{includes=paths}) , listFieldWithSep vcat "install-includes" showFilePath parseFilePathQ installIncludes (\paths binfo -> binfo{installIncludes=paths}) , listField "include-dirs" showFilePath parseFilePathQ includeDirs (\paths binfo -> binfo{includeDirs=paths}) , listField "hs-source-dirs" showFilePath parseFilePathQ hsSourceDirs (\paths binfo -> binfo{hsSourceDirs=paths}) , listFieldWithSep vcat "other-modules" disp parseModuleNameQ otherModules (\val binfo -> binfo{otherModules=val}) , optsField "ghc-prof-options" GHC profOptions (\val binfo -> binfo{profOptions=val}) , optsField "ghcjs-prof-options" GHCJS profOptions (\val binfo -> binfo{profOptions=val}) , optsField "ghc-shared-options" GHC sharedOptions (\val binfo -> binfo{sharedOptions=val}) , optsField "ghcjs-shared-options" GHCJS sharedOptions (\val binfo -> binfo{sharedOptions=val}) , optsField "ghc-options" GHC options (\path binfo -> binfo{options=path}) , optsField "ghcjs-options" GHCJS options (\path binfo -> binfo{options=path}) , optsField "jhc-options" JHC options (\path binfo -> binfo{options=path}) -- NOTE: Hugs and NHC are not supported anymore, but these fields are kept -- around for backwards compatibility. , optsField "hugs-options" Hugs options (const id) , optsField "nhc98-options" NHC options (const id) ] storeXFieldsBI :: UnrecFieldParser BuildInfo storeXFieldsBI (f@('x':'-':_),val) bi = Just bi{ customFieldsBI = (f,val):customFieldsBI bi } storeXFieldsBI _ _ = Nothing ------------------------------------------------------------------------------ flagFieldDescrs :: [FieldDescr Flag] flagFieldDescrs = [ simpleField "description" showFreeText parseFreeText flagDescription (\val fl -> fl{ flagDescription = val }) , boolField "default" flagDefault (\val fl -> fl{ flagDefault = val }) , boolField "manual" flagManual (\val fl -> fl{ flagManual = val }) ] ------------------------------------------------------------------------------ sourceRepoFieldDescrs :: [FieldDescr SourceRepo] sourceRepoFieldDescrs = [ simpleField "type" (maybe empty disp) (fmap Just parse) repoType (\val repo -> repo { repoType = val }) , simpleField "location" (maybe empty showFreeText) (fmap Just parseFreeText) repoLocation (\val repo -> repo { repoLocation = val }) , simpleField "module" (maybe empty showToken) (fmap Just parseTokenQ) repoModule (\val repo -> repo { repoModule = val }) , simpleField "branch" (maybe empty showToken) (fmap Just parseTokenQ) repoBranch (\val repo -> repo { repoBranch = val }) , simpleField "tag" (maybe empty showToken) (fmap Just parseTokenQ) repoTag (\val repo -> repo { repoTag = val }) , simpleField "subdir" (maybe empty showFilePath) (fmap Just parseFilePathQ) repoSubdir (\val repo -> repo { repoSubdir = val }) ] -- --------------------------------------------------------------- -- Parsing -- | Given a parser and a filename, return the parse of the file, -- after checking if the file exists. readAndParseFile :: (FilePath -> (String -> IO a) -> IO a) -> (String -> ParseResult a) -> Verbosity -> FilePath -> IO a readAndParseFile withFileContents' parser verbosity fpath = do exists <- doesFileExist fpath unless exists (die $ "Error Parsing: file \"" ++ fpath ++ "\" doesn't exist. Cannot continue.") withFileContents' fpath $ \str -> case parser str of ParseFailed e -> do let (line, message) = locatedErrorMsg e dieWithLocation fpath line message ParseOk warnings x -> do mapM_ (warn verbosity . showPWarning fpath) $ reverse warnings return x readHookedBuildInfo :: Verbosity -> FilePath -> IO HookedBuildInfo readHookedBuildInfo = readAndParseFile withFileContents parseHookedBuildInfo -- |Parse the given package file. readPackageDescription :: Verbosity -> FilePath -> IO GenericPackageDescription readPackageDescription = readAndParseFile withUTF8FileContents parsePackageDescription stanzas :: [Field] -> [[Field]] stanzas [] = [] stanzas (f:fields) = (f:this) : stanzas rest where (this, rest) = break isStanzaHeader fields isStanzaHeader :: Field -> Bool isStanzaHeader (F _ f _) = f == "executable" isStanzaHeader _ = False ------------------------------------------------------------------------------ mapSimpleFields :: (Field -> ParseResult Field) -> [Field] -> ParseResult [Field] mapSimpleFields f = mapM walk where walk fld@F{} = f fld walk (IfBlock l c fs1 fs2) = do fs1' <- mapM walk fs1 fs2' <- mapM walk fs2 return (IfBlock l c fs1' fs2') walk (Section ln n l fs1) = do fs1' <- mapM walk fs1 return (Section ln n l fs1') -- prop_isMapM fs = mapSimpleFields return fs == return fs -- names of fields that represents dependencies, thus consrca constraintFieldNames :: [String] constraintFieldNames = ["build-depends"] -- Possible refactoring would be to have modifiers be explicit about what -- they add and define an accessor that specifies what the dependencies -- are. This way we would completely reuse the parsing knowledge from the -- field descriptor. parseConstraint :: Field -> ParseResult [DependencyWithRenaming] parseConstraint (F l n v) | n == "build-depends" = runP l n (parseCommaList parse) v parseConstraint f = userBug $ "Constraint was expected (got: " ++ show f ++ ")" {- headerFieldNames :: [String] headerFieldNames = filter (\n -> not (n `elem` constraintFieldNames)) . map fieldName $ pkgDescrFieldDescrs -} libFieldNames :: [String] libFieldNames = map fieldName libFieldDescrs ++ buildInfoNames ++ constraintFieldNames -- exeFieldNames :: [String] -- exeFieldNames = map fieldName executableFieldDescrs -- ++ buildInfoNames buildInfoNames :: [String] buildInfoNames = map fieldName binfoFieldDescrs ++ map fst deprecatedFieldsBuildInfo -- A minimal implementation of the StateT monad transformer to avoid depending -- on the 'mtl' package. newtype StT s m a = StT { runStT :: s -> m (a,s) } instance Functor f => Functor (StT s f) where fmap g (StT f) = StT $ fmap (first g) . f instance (Monad m, Functor m) => Applicative (StT s m) where pure = return (<*>) = ap instance Monad m => Monad (StT s m) where return a = StT (\s -> return (a,s)) StT f >>= g = StT $ \s -> do (a,s') <- f s runStT (g a) s' get :: Monad m => StT s m s get = StT $ \s -> return (s, s) modify :: Monad m => (s -> s) -> StT s m () modify f = StT $ \s -> return ((),f s) lift :: Monad m => m a -> StT s m a lift m = StT $ \s -> m >>= \a -> return (a,s) evalStT :: Monad m => StT s m a -> s -> m a evalStT st s = liftM fst $ runStT st s -- Our monad for parsing a list/tree of fields. -- -- The state represents the remaining fields to be processed. type PM a = StT [Field] ParseResult a -- return look-ahead field or nothing if we're at the end of the file peekField :: PM (Maybe Field) peekField = liftM listToMaybe get -- Unconditionally discard the first field in our state. Will error when it -- reaches end of file. (Yes, that's evil.) skipField :: PM () skipField = modify tail --FIXME: this should take a ByteString, not a String. We have to be able to -- decode UTF8 and handle the BOM. -- | Parses the given file into a 'GenericPackageDescription'. -- -- In Cabal 1.2 the syntax for package descriptions was changed to a format -- with sections and possibly indented property descriptions. parsePackageDescription :: String -> ParseResult GenericPackageDescription parsePackageDescription file = do -- This function is quite complex because it needs to be able to parse -- both pre-Cabal-1.2 and post-Cabal-1.2 files. Additionally, it contains -- a lot of parser-related noise since we do not want to depend on Parsec. -- -- If we detect an pre-1.2 file we implicitly convert it to post-1.2 -- style. See 'sectionizeFields' below for details about the conversion. fields0 <- readFields file `catchParseError` \err -> let tabs = findIndentTabs file in case err of -- In case of a TabsError report them all at once. TabsError tabLineNo -> reportTabsError -- but only report the ones including and following -- the one that caused the actual error [ t | t@(lineNo',_) <- tabs , lineNo' >= tabLineNo ] _ -> parseFail err let cabalVersionNeeded = head $ [ minVersionBound versionRange | Just versionRange <- [ simpleParse v | F _ "cabal-version" v <- fields0 ] ] ++ [Version [0] []] minVersionBound versionRange = case asVersionIntervals versionRange of [] -> Version [0] [] ((LowerBound version _, _):_) -> version handleFutureVersionParseFailure cabalVersionNeeded $ do let sf = sectionizeFields fields0 -- ensure 1.2 format -- figure out and warn about deprecated stuff (warnings are collected -- inside our parsing monad) fields <- mapSimpleFields deprecField sf -- Our parsing monad takes the not-yet-parsed fields as its state. -- After each successful parse we remove the field from the state -- ('skipField') and move on to the next one. -- -- Things are complicated a bit, because fields take a tree-like -- structure -- they can be sections or "if"/"else" conditionals. flip evalStT fields $ do -- The header consists of all simple fields up to the first section -- (flag, library, executable). header_fields <- getHeader [] -- Parses just the header fields and stores them in a -- 'PackageDescription'. Note that our final result is a -- 'GenericPackageDescription'; for pragmatic reasons we just store -- the partially filled-out 'PackageDescription' inside the -- 'GenericPackageDescription'. pkg <- lift $ parseFields pkgDescrFieldDescrs storeXFieldsPD emptyPackageDescription header_fields -- 'getBody' assumes that the remaining fields only consist of -- flags, lib and exe sections. (repos, flags, mlib, exes, tests, bms) <- getBody warnIfRest -- warn if getBody did not parse up to the last field. -- warn about using old/new syntax with wrong cabal-version: maybeWarnCabalVersion (not $ oldSyntax fields0) pkg checkForUndefinedFlags flags mlib exes tests return $ GenericPackageDescription pkg { sourceRepos = repos } flags mlib exes tests bms where oldSyntax = all isSimpleField reportTabsError tabs = syntaxError (fst (head tabs)) $ "Do not use tabs for indentation (use spaces instead)\n" ++ " Tabs were used at (line,column): " ++ show tabs maybeWarnCabalVersion newsyntax pkg | newsyntax && specVersion pkg < Version [1,2] [] = lift $ warning $ "A package using section syntax must specify at least\n" ++ "'cabal-version: >= 1.2'." maybeWarnCabalVersion newsyntax pkg | not newsyntax && specVersion pkg >= Version [1,2] [] = lift $ warning $ "A package using 'cabal-version: " ++ displaySpecVersion (specVersionRaw pkg) ++ "' must use section syntax. See the Cabal user guide for details." where displaySpecVersion (Left version) = display version displaySpecVersion (Right versionRange) = case asVersionIntervals versionRange of [] {- impossible -} -> display versionRange ((LowerBound version _, _):_) -> display (orLaterVersion version) maybeWarnCabalVersion _ _ = return () handleFutureVersionParseFailure cabalVersionNeeded parseBody = (unless versionOk (warning message) >> parseBody) `catchParseError` \parseError -> case parseError of TabsError _ -> parseFail parseError _ | versionOk -> parseFail parseError | otherwise -> fail message where versionOk = cabalVersionNeeded <= cabalVersion message = "This package requires at least Cabal version " ++ display cabalVersionNeeded -- "Sectionize" an old-style Cabal file. A sectionized file has: -- -- * all global fields at the beginning, followed by -- -- * all flag declarations, followed by -- -- * an optional library section, and an arbitrary number of executable -- sections (in any order). -- -- The current implementation just gathers all library-specific fields -- in a library section and wraps all executable stanzas in an executable -- section. sectionizeFields :: [Field] -> [Field] sectionizeFields fs | oldSyntax fs = let -- "build-depends" is a local field now. To be backwards -- compatible, we still allow it as a global field in old-style -- package description files and translate it to a local field by -- adding it to every non-empty section (hdr0, exes0) = break ((=="executable") . fName) fs (hdr, libfs0) = partition (not . (`elem` libFieldNames) . fName) hdr0 (deps, libfs) = partition ((== "build-depends") . fName) libfs0 exes = unfoldr toExe exes0 toExe [] = Nothing toExe (F l e n : r) | e == "executable" = let (efs, r') = break ((=="executable") . fName) r in Just (Section l "executable" n (deps ++ efs), r') toExe _ = cabalBug "unexpected input to 'toExe'" in hdr ++ (if null libfs then [] else [Section (lineNo (head libfs)) "library" "" (deps ++ libfs)]) ++ exes | otherwise = fs isSimpleField F{} = True isSimpleField _ = False -- warn if there's something at the end of the file warnIfRest :: PM () warnIfRest = do s <- get case s of [] -> return () _ -> lift $ warning "Ignoring trailing declarations." -- add line no. -- all simple fields at the beginning of the file are (considered) header -- fields getHeader :: [Field] -> PM [Field] getHeader acc = peekField >>= \mf -> case mf of Just f@F{} -> skipField >> getHeader (f:acc) _ -> return (reverse acc) -- -- body ::= { repo | flag | library | executable | test }+ -- at most one lib -- -- The body consists of an optional sequence of declarations of flags and -- an arbitrary number of executables and at most one library. getBody :: PM ([SourceRepo], [Flag] ,Maybe (CondTree ConfVar [Dependency] Library) ,[(String, CondTree ConfVar [Dependency] Executable)] ,[(String, CondTree ConfVar [Dependency] TestSuite)] ,[(String, CondTree ConfVar [Dependency] Benchmark)]) getBody = peekField >>= \mf -> case mf of Just (Section line_no sec_type sec_label sec_fields) | sec_type == "executable" -> do when (null sec_label) $ lift $ syntaxError line_no "'executable' needs one argument (the executable's name)" exename <- lift $ runP line_no "executable" parseTokenQ sec_label flds <- collectFields parseExeFields sec_fields skipField (repos, flags, lib, exes, tests, bms) <- getBody return (repos, flags, lib, (exename, flds): exes, tests, bms) | sec_type == "test-suite" -> do when (null sec_label) $ lift $ syntaxError line_no "'test-suite' needs one argument (the test suite's name)" testname <- lift $ runP line_no "test" parseTokenQ sec_label flds <- collectFields (parseTestFields line_no) sec_fields -- Check that a valid test suite type has been chosen. A type -- field may be given inside a conditional block, so we must -- check for that before complaining that a type field has not -- been given. The test suite must always have a valid type, so -- we need to check both the 'then' and 'else' blocks, though -- the blocks need not have the same type. let checkTestType ts ct = let ts' = mappend ts $ condTreeData ct -- If a conditional has only a 'then' block and no -- 'else' block, then it cannot have a valid type -- in every branch, unless the type is specified at -- a higher level in the tree. checkComponent (_, _, Nothing) = False -- If a conditional has a 'then' block and an 'else' -- block, both must specify a test type, unless the -- type is specified higher in the tree. checkComponent (_, t, Just e) = checkTestType ts' t && checkTestType ts' e -- Does the current node specify a test type? hasTestType = testInterface ts' /= testInterface emptyTestSuite components = condTreeComponents ct -- If the current level of the tree specifies a type, -- then we are done. If not, then one of the conditional -- branches below the current node must specify a type. -- Each node may have multiple immediate children; we -- only one need one to specify a type because the -- configure step uses 'mappend' to join together the -- results of flag resolution. in hasTestType || any checkComponent components if checkTestType emptyTestSuite flds then do skipField (repos, flags, lib, exes, tests, bms) <- getBody return (repos, flags, lib, exes, (testname, flds) : tests, bms) else lift $ syntaxError line_no $ "Test suite \"" ++ testname ++ "\" is missing required field \"type\" or the field " ++ "is not present in all conditional branches. The " ++ "available test types are: " ++ intercalate ", " (map display knownTestTypes) | sec_type == "benchmark" -> do when (null sec_label) $ lift $ syntaxError line_no "'benchmark' needs one argument (the benchmark's name)" benchname <- lift $ runP line_no "benchmark" parseTokenQ sec_label flds <- collectFields (parseBenchmarkFields line_no) sec_fields -- Check that a valid benchmark type has been chosen. A type -- field may be given inside a conditional block, so we must -- check for that before complaining that a type field has not -- been given. The benchmark must always have a valid type, so -- we need to check both the 'then' and 'else' blocks, though -- the blocks need not have the same type. let checkBenchmarkType ts ct = let ts' = mappend ts $ condTreeData ct -- If a conditional has only a 'then' block and no -- 'else' block, then it cannot have a valid type -- in every branch, unless the type is specified at -- a higher level in the tree. checkComponent (_, _, Nothing) = False -- If a conditional has a 'then' block and an 'else' -- block, both must specify a benchmark type, unless the -- type is specified higher in the tree. checkComponent (_, t, Just e) = checkBenchmarkType ts' t && checkBenchmarkType ts' e -- Does the current node specify a benchmark type? hasBenchmarkType = benchmarkInterface ts' /= benchmarkInterface emptyBenchmark components = condTreeComponents ct -- If the current level of the tree specifies a type, -- then we are done. If not, then one of the conditional -- branches below the current node must specify a type. -- Each node may have multiple immediate children; we -- only one need one to specify a type because the -- configure step uses 'mappend' to join together the -- results of flag resolution. in hasBenchmarkType || any checkComponent components if checkBenchmarkType emptyBenchmark flds then do skipField (repos, flags, lib, exes, tests, bms) <- getBody return (repos, flags, lib, exes, tests, (benchname, flds) : bms) else lift $ syntaxError line_no $ "Benchmark \"" ++ benchname ++ "\" is missing required field \"type\" or the field " ++ "is not present in all conditional branches. The " ++ "available benchmark types are: " ++ intercalate ", " (map display knownBenchmarkTypes) | sec_type == "library" -> do unless (null sec_label) $ lift $ syntaxError line_no "'library' expects no argument" flds <- collectFields parseLibFields sec_fields skipField (repos, flags, lib, exes, tests, bms) <- getBody when (isJust lib) $ lift $ syntaxError line_no "There can only be one library section in a package description." return (repos, flags, Just flds, exes, tests, bms) | sec_type == "flag" -> do when (null sec_label) $ lift $ syntaxError line_no "'flag' needs one argument (the flag's name)" flag <- lift $ parseFields flagFieldDescrs warnUnrec (MkFlag (FlagName (lowercase sec_label)) "" True False) sec_fields skipField (repos, flags, lib, exes, tests, bms) <- getBody return (repos, flag:flags, lib, exes, tests, bms) | sec_type == "source-repository" -> do when (null sec_label) $ lift $ syntaxError line_no $ "'source-repository' needs one argument, " ++ "the repo kind which is usually 'head' or 'this'" kind <- case simpleParse sec_label of Just kind -> return kind Nothing -> lift $ syntaxError line_no $ "could not parse repo kind: " ++ sec_label repo <- lift $ parseFields sourceRepoFieldDescrs warnUnrec SourceRepo { repoKind = kind, repoType = Nothing, repoLocation = Nothing, repoModule = Nothing, repoBranch = Nothing, repoTag = Nothing, repoSubdir = Nothing } sec_fields skipField (repos, flags, lib, exes, tests, bms) <- getBody return (repo:repos, flags, lib, exes, tests, bms) | otherwise -> do lift $ warning $ "Ignoring unknown section type: " ++ sec_type skipField getBody Just f@(F {}) -> do _ <- lift $ syntaxError (lineNo f) $ "Plain fields are not allowed in between stanzas: " ++ show f skipField getBody Just f@(IfBlock {}) -> do _ <- lift $ syntaxError (lineNo f) $ "If-blocks are not allowed in between stanzas: " ++ show f skipField getBody Nothing -> return ([], [], Nothing, [], [], []) -- Extracts all fields in a block and returns a 'CondTree'. -- -- We have to recurse down into conditionals and we treat fields that -- describe dependencies specially. collectFields :: ([Field] -> PM a) -> [Field] -> PM (CondTree ConfVar [Dependency] a) collectFields parser allflds = do let simplFlds = [ F l n v | F l n v <- allflds ] condFlds = [ f | f@IfBlock{} <- allflds ] sections = [ s | s@Section{} <- allflds ] -- Put these through the normal parsing pass too, so that we -- collect the ModRenamings let depFlds = filter isConstraint simplFlds mapM_ (\(Section l n _ _) -> lift . warning $ "Unexpected section '" ++ n ++ "' on line " ++ show l) sections a <- parser simplFlds deps <- liftM concat . mapM (lift . fmap (map dependency) . parseConstraint) $ depFlds ifs <- mapM processIfs condFlds return (CondNode a deps ifs) where isConstraint (F _ n _) = n `elem` constraintFieldNames isConstraint _ = False processIfs (IfBlock l c t e) = do cnd <- lift $ runP l "if" parseCondition c t' <- collectFields parser t e' <- case e of [] -> return Nothing es -> do fs <- collectFields parser es return (Just fs) return (cnd, t', e') processIfs _ = cabalBug "processIfs called with wrong field type" parseLibFields :: [Field] -> PM Library parseLibFields = lift . parseFields libFieldDescrs storeXFieldsLib emptyLibrary -- Note: we don't parse the "executable" field here, hence the tail hack. parseExeFields :: [Field] -> PM Executable parseExeFields = lift . parseFields (tail executableFieldDescrs) storeXFieldsExe emptyExecutable parseTestFields :: LineNo -> [Field] -> PM TestSuite parseTestFields line fields = do x <- lift $ parseFields testSuiteFieldDescrs storeXFieldsTest emptyTestStanza fields lift $ validateTestSuite line x parseBenchmarkFields :: LineNo -> [Field] -> PM Benchmark parseBenchmarkFields line fields = do x <- lift $ parseFields benchmarkFieldDescrs storeXFieldsBenchmark emptyBenchmarkStanza fields lift $ validateBenchmark line x checkForUndefinedFlags :: [Flag] -> Maybe (CondTree ConfVar [Dependency] Library) -> [(String, CondTree ConfVar [Dependency] Executable)] -> [(String, CondTree ConfVar [Dependency] TestSuite)] -> PM () checkForUndefinedFlags flags mlib exes tests = do let definedFlags = map flagName flags maybe (return ()) (checkCondTreeFlags definedFlags) mlib mapM_ (checkCondTreeFlags definedFlags . snd) exes mapM_ (checkCondTreeFlags definedFlags . snd) tests checkCondTreeFlags :: [FlagName] -> CondTree ConfVar c a -> PM () checkCondTreeFlags definedFlags ct = do let fv = nub $ freeVars ct unless (all (`elem` definedFlags) fv) $ fail $ "These flags are used without having been defined: " ++ intercalate ", " [ n | FlagName n <- fv \\ definedFlags ] -- | Parse a list of fields, given a list of field descriptions, -- a structure to accumulate the parsed fields, and a function -- that can decide what to do with fields which don't match any -- of the field descriptions. parseFields :: [FieldDescr a] -- ^ descriptions of fields we know how to -- parse -> UnrecFieldParser a -- ^ possibly do something with -- unrecognized fields -> a -- ^ accumulator -> [Field] -- ^ fields to be parsed -> ParseResult a parseFields descrs unrec ini fields = do (a, unknowns) <- foldM (parseField descrs unrec) (ini, []) fields unless (null unknowns) $ warning $ render $ text "Unknown fields:" <+> commaSep (map (\(l,u) -> u ++ " (line " ++ show l ++ ")") (reverse unknowns)) $+$ text "Fields allowed in this section:" $$ nest 4 (commaSep $ map fieldName descrs) return a where commaSep = fsep . punctuate comma . map text parseField :: [FieldDescr a] -- ^ list of parseable fields -> UnrecFieldParser a -- ^ possibly do something with -- unrecognized fields -> (a,[(Int,String)]) -- ^ accumulated result and warnings -> Field -- ^ the field to be parsed -> ParseResult (a, [(Int,String)]) parseField (FieldDescr name _ parser : fields) unrec (a, us) (F line f val) | name == f = parser line val a >>= \a' -> return (a',us) | otherwise = parseField fields unrec (a,us) (F line f val) parseField [] unrec (a,us) (F l f val) = return $ case unrec (f,val) a of -- no fields matched, see if the 'unrec' Just a' -> (a',us) -- function wants to do anything with it Nothing -> (a, (l,f):us) parseField _ _ _ _ = cabalBug "'parseField' called on a non-field" deprecatedFields :: [(String,String)] deprecatedFields = deprecatedFieldsPkgDescr ++ deprecatedFieldsBuildInfo deprecatedFieldsPkgDescr :: [(String,String)] deprecatedFieldsPkgDescr = [ ("other-files", "extra-source-files") ] deprecatedFieldsBuildInfo :: [(String,String)] deprecatedFieldsBuildInfo = [ ("hs-source-dir","hs-source-dirs") ] -- Handle deprecated fields deprecField :: Field -> ParseResult Field deprecField (F line fld val) = do fld' <- case lookup fld deprecatedFields of Nothing -> return fld Just newName -> do warning $ "The field \"" ++ fld ++ "\" is deprecated, please use \"" ++ newName ++ "\"" return newName return (F line fld' val) deprecField _ = cabalBug "'deprecField' called on a non-field" parseHookedBuildInfo :: String -> ParseResult HookedBuildInfo parseHookedBuildInfo inp = do fields <- readFields inp let ss@(mLibFields:exes) = stanzas fields mLib <- parseLib mLibFields biExes <- mapM parseExe (maybe ss (const exes) mLib) return (mLib, biExes) where parseLib :: [Field] -> ParseResult (Maybe BuildInfo) parseLib (bi@(F _ inFieldName _:_)) | lowercase inFieldName /= "executable" = liftM Just (parseBI bi) parseLib _ = return Nothing parseExe :: [Field] -> ParseResult (String, BuildInfo) parseExe (F line inFieldName mName:bi) | lowercase inFieldName == "executable" = do bis <- parseBI bi return (mName, bis) | otherwise = syntaxError line "expecting 'executable' at top of stanza" parseExe (_:_) = cabalBug "`parseExe' called on a non-field" parseExe [] = syntaxError 0 "error in parsing buildinfo file. Expected executable stanza" parseBI st = parseFields binfoFieldDescrs storeXFieldsBI emptyBuildInfo st -- --------------------------------------------------------------------------- -- Pretty printing writePackageDescription :: FilePath -> PackageDescription -> IO () writePackageDescription fpath pkg = writeUTF8File fpath (showPackageDescription pkg) --TODO: make this use section syntax -- add equivalent for GenericPackageDescription showPackageDescription :: PackageDescription -> String showPackageDescription pkg = render $ ppPackage pkg $$ ppCustomFields (customFieldsPD pkg) $$ (case library pkg of Nothing -> empty Just lib -> ppLibrary lib) $$ vcat [ space $$ ppExecutable exe | exe <- executables pkg ] where ppPackage = ppFields pkgDescrFieldDescrs ppLibrary = ppFields libFieldDescrs ppExecutable = ppFields executableFieldDescrs ppCustomFields :: [(String,String)] -> Doc ppCustomFields flds = vcat (map ppCustomField flds) ppCustomField :: (String,String) -> Doc ppCustomField (name,val) = text name <> colon <+> showFreeText val writeHookedBuildInfo :: FilePath -> HookedBuildInfo -> IO () writeHookedBuildInfo fpath = writeFileAtomic fpath . BS.Char8.pack . showHookedBuildInfo showHookedBuildInfo :: HookedBuildInfo -> String showHookedBuildInfo (mb_lib_bi, ex_bis) = render $ (case mb_lib_bi of Nothing -> empty Just bi -> ppBuildInfo bi) $$ vcat [ space $$ text "executable:" <+> text name $$ ppBuildInfo bi | (name, bi) <- ex_bis ] where ppBuildInfo bi = ppFields binfoFieldDescrs bi $$ ppCustomFields (customFieldsBI bi) -- replace all tabs used as indentation with whitespace, also return where -- tabs were found findIndentTabs :: String -> [(Int,Int)] findIndentTabs = concatMap checkLine . zip [1..] . lines where checkLine (lineno, l) = let (indent, _content) = span isSpace l tabCols = map fst . filter ((== '\t') . snd) . zip [0..] addLineNo = map (\col -> (lineno,col)) in addLineNo (tabCols indent) --test_findIndentTabs = findIndentTabs $ unlines $ -- [ "foo", " bar", " \t baz", "\t biz\t", "\t\t \t mib" ] -- | Dependencies plus module renamings. This is what users specify; however, -- renaming information is not used for dependency resolution. data DependencyWithRenaming = DependencyWithRenaming Dependency ModuleRenaming deriving (Read, Show, Eq, Typeable, Data) dependency :: DependencyWithRenaming -> Dependency dependency (DependencyWithRenaming dep _) = dep instance Text DependencyWithRenaming where disp (DependencyWithRenaming d rns) = disp d <+> disp rns parse = do d <- parse Parse.skipSpaces rns <- parse Parse.skipSpaces return (DependencyWithRenaming d rns) buildDependsWithRenaming :: BuildInfo -> [DependencyWithRenaming] buildDependsWithRenaming pkg = map (\dep@(Dependency n _) -> DependencyWithRenaming dep (Map.findWithDefault defaultRenaming n (targetBuildRenaming pkg))) (targetBuildDepends pkg) setBuildDependsWithRenaming :: [DependencyWithRenaming] -> BuildInfo -> BuildInfo setBuildDependsWithRenaming deps pkg = pkg { targetBuildDepends = map dependency deps, targetBuildRenaming = Map.fromList (map (\(DependencyWithRenaming (Dependency n _) rns) -> (n, rns)) deps) } Cabal-1.22.5.0/Distribution/PackageDescription/PrettyPrint.hs0000644000000000000000000002524312627136220022214 0ustar0000000000000000{-# LANGUAGE CPP #-} ----------------------------------------------------------------------------- -- | -- Module : Distribution.PackageDescription.PrettyPrint -- Copyright : Jürgen Nicklisch-Franken 2010 -- License : BSD3 -- -- Maintainer : cabal-devel@haskell.org -- Stability : provisional -- Portability : portable -- -- Pretty printing for cabal files -- ----------------------------------------------------------------------------- module Distribution.PackageDescription.PrettyPrint ( writeGenericPackageDescription, showGenericPackageDescription, ) where #if __GLASGOW_HASKELL__ < 710 import Data.Monoid (Monoid(mempty)) #endif import Distribution.PackageDescription ( Benchmark(..), BenchmarkInterface(..), benchmarkType , TestSuite(..), TestSuiteInterface(..), testType , SourceRepo(..), customFieldsBI, CondTree(..), Condition(..), FlagName(..), ConfVar(..), Executable(..), Library(..), Flag(..), PackageDescription(..), GenericPackageDescription(..)) import Text.PrettyPrint (hsep, parens, char, nest, empty, isEmpty, ($$), (<+>), colon, (<>), text, vcat, ($+$), Doc, render) import Distribution.Simple.Utils (writeUTF8File) import Distribution.ParseUtils (showFreeText, FieldDescr(..), indentWith, ppField, ppFields) import Distribution.PackageDescription.Parse (pkgDescrFieldDescrs,binfoFieldDescrs,libFieldDescrs, sourceRepoFieldDescrs,flagFieldDescrs) import Distribution.Package (Dependency(..)) import Distribution.Text (Text(..)) import Data.Maybe (isJust, fromJust, isNothing) -- | Recompile with false for regression testing simplifiedPrinting :: Bool simplifiedPrinting = False -- | Writes a .cabal file from a generic package description writeGenericPackageDescription :: FilePath -> GenericPackageDescription -> IO () writeGenericPackageDescription fpath pkg = writeUTF8File fpath (showGenericPackageDescription pkg) -- | Writes a generic package description to a string showGenericPackageDescription :: GenericPackageDescription -> String showGenericPackageDescription = render . ppGenericPackageDescription ppGenericPackageDescription :: GenericPackageDescription -> Doc ppGenericPackageDescription gpd = ppPackageDescription (packageDescription gpd) $+$ ppGenPackageFlags (genPackageFlags gpd) $+$ ppLibrary (condLibrary gpd) $+$ ppExecutables (condExecutables gpd) $+$ ppTestSuites (condTestSuites gpd) $+$ ppBenchmarks (condBenchmarks gpd) ppPackageDescription :: PackageDescription -> Doc ppPackageDescription pd = ppFields pkgDescrFieldDescrs pd $+$ ppCustomFields (customFieldsPD pd) $+$ ppSourceRepos (sourceRepos pd) ppSourceRepos :: [SourceRepo] -> Doc ppSourceRepos [] = empty ppSourceRepos (hd:tl) = ppSourceRepo hd $+$ ppSourceRepos tl ppSourceRepo :: SourceRepo -> Doc ppSourceRepo repo = emptyLine $ text "source-repository" <+> disp (repoKind repo) $+$ (nest indentWith (ppFields sourceRepoFieldDescrs' repo)) where sourceRepoFieldDescrs' = [fd | fd <- sourceRepoFieldDescrs, fieldName fd /= "kind"] -- TODO: this is a temporary hack. Ideally, fields containing default values -- would be filtered out when the @FieldDescr a@ list is generated. ppFieldsFiltered :: [(String, String)] -> [FieldDescr a] -> a -> Doc ppFieldsFiltered removable fields x = ppFields (filter nondefault fields) x where nondefault (FieldDescr name getter _) = maybe True (render (getter x) /=) (lookup name removable) binfoDefaults :: [(String, String)] binfoDefaults = [("buildable", "True")] libDefaults :: [(String, String)] libDefaults = ("exposed", "True") : binfoDefaults flagDefaults :: [(String, String)] flagDefaults = [("default", "True"), ("manual", "False")] ppDiffFields :: [FieldDescr a] -> a -> a -> Doc ppDiffFields fields x y = vcat [ ppField name (getter x) | FieldDescr name getter _ <- fields , render (getter x) /= render (getter y) ] ppCustomFields :: [(String,String)] -> Doc ppCustomFields flds = vcat [ppCustomField f | f <- flds] ppCustomField :: (String,String) -> Doc ppCustomField (name,val) = text name <> colon <+> showFreeText val ppGenPackageFlags :: [Flag] -> Doc ppGenPackageFlags flds = vcat [ppFlag f | f <- flds] ppFlag :: Flag -> Doc ppFlag flag@(MkFlag name _ _ _) = emptyLine $ text "flag" <+> ppFlagName name $+$ nest indentWith fields where fields = ppFieldsFiltered flagDefaults flagFieldDescrs flag ppLibrary :: (Maybe (CondTree ConfVar [Dependency] Library)) -> Doc ppLibrary Nothing = empty ppLibrary (Just condTree) = emptyLine $ text "library" $+$ nest indentWith (ppCondTree condTree Nothing ppLib) where ppLib lib Nothing = ppFieldsFiltered libDefaults libFieldDescrs lib $$ ppCustomFields (customFieldsBI (libBuildInfo lib)) ppLib lib (Just plib) = ppDiffFields libFieldDescrs lib plib $$ ppCustomFields (customFieldsBI (libBuildInfo lib)) ppExecutables :: [(String, CondTree ConfVar [Dependency] Executable)] -> Doc ppExecutables exes = vcat [emptyLine $ text ("executable " ++ n) $+$ nest indentWith (ppCondTree condTree Nothing ppExe)| (n,condTree) <- exes] where ppExe (Executable _ modulePath' buildInfo') Nothing = (if modulePath' == "" then empty else text "main-is:" <+> text modulePath') $+$ ppFieldsFiltered binfoDefaults binfoFieldDescrs buildInfo' $+$ ppCustomFields (customFieldsBI buildInfo') ppExe (Executable _ modulePath' buildInfo') (Just (Executable _ modulePath2 buildInfo2)) = (if modulePath' == "" || modulePath' == modulePath2 then empty else text "main-is:" <+> text modulePath') $+$ ppDiffFields binfoFieldDescrs buildInfo' buildInfo2 $+$ ppCustomFields (customFieldsBI buildInfo') ppTestSuites :: [(String, CondTree ConfVar [Dependency] TestSuite)] -> Doc ppTestSuites suites = emptyLine $ vcat [ text ("test-suite " ++ n) $+$ nest indentWith (ppCondTree condTree Nothing ppTestSuite) | (n,condTree) <- suites] where ppTestSuite testsuite Nothing = maybe empty (\t -> text "type:" <+> disp t) maybeTestType $+$ maybe empty (\f -> text "main-is:" <+> text f) (testSuiteMainIs testsuite) $+$ maybe empty (\m -> text "test-module:" <+> disp m) (testSuiteModule testsuite) $+$ ppFieldsFiltered binfoDefaults binfoFieldDescrs (testBuildInfo testsuite) $+$ ppCustomFields (customFieldsBI (testBuildInfo testsuite)) where maybeTestType | testInterface testsuite == mempty = Nothing | otherwise = Just (testType testsuite) ppTestSuite (TestSuite _ _ buildInfo' _) (Just (TestSuite _ _ buildInfo2 _)) = ppDiffFields binfoFieldDescrs buildInfo' buildInfo2 $+$ ppCustomFields (customFieldsBI buildInfo') testSuiteMainIs test = case testInterface test of TestSuiteExeV10 _ f -> Just f _ -> Nothing testSuiteModule test = case testInterface test of TestSuiteLibV09 _ m -> Just m _ -> Nothing ppBenchmarks :: [(String, CondTree ConfVar [Dependency] Benchmark)] -> Doc ppBenchmarks suites = emptyLine $ vcat [ text ("benchmark " ++ n) $+$ nest indentWith (ppCondTree condTree Nothing ppBenchmark) | (n,condTree) <- suites] where ppBenchmark benchmark Nothing = maybe empty (\t -> text "type:" <+> disp t) maybeBenchmarkType $+$ maybe empty (\f -> text "main-is:" <+> text f) (benchmarkMainIs benchmark) $+$ ppFieldsFiltered binfoDefaults binfoFieldDescrs (benchmarkBuildInfo benchmark) $+$ ppCustomFields (customFieldsBI (benchmarkBuildInfo benchmark)) where maybeBenchmarkType | benchmarkInterface benchmark == mempty = Nothing | otherwise = Just (benchmarkType benchmark) ppBenchmark (Benchmark _ _ buildInfo' _) (Just (Benchmark _ _ buildInfo2 _)) = ppDiffFields binfoFieldDescrs buildInfo' buildInfo2 $+$ ppCustomFields (customFieldsBI buildInfo') benchmarkMainIs benchmark = case benchmarkInterface benchmark of BenchmarkExeV10 _ f -> Just f _ -> Nothing ppCondition :: Condition ConfVar -> Doc ppCondition (Var x) = ppConfVar x ppCondition (Lit b) = text (show b) ppCondition (CNot c) = char '!' <> (ppCondition c) ppCondition (COr c1 c2) = parens (hsep [ppCondition c1, text "||" <+> ppCondition c2]) ppCondition (CAnd c1 c2) = parens (hsep [ppCondition c1, text "&&" <+> ppCondition c2]) ppConfVar :: ConfVar -> Doc ppConfVar (OS os) = text "os" <> parens (disp os) ppConfVar (Arch arch) = text "arch" <> parens (disp arch) ppConfVar (Flag name) = text "flag" <> parens (ppFlagName name) ppConfVar (Impl c v) = text "impl" <> parens (disp c <+> disp v) ppFlagName :: FlagName -> Doc ppFlagName (FlagName name) = text name ppCondTree :: CondTree ConfVar [Dependency] a -> Maybe a -> (a -> Maybe a -> Doc) -> Doc ppCondTree ct@(CondNode it _ ifs) mbIt ppIt = let res = (vcat $ map ppIf ifs) $+$ ppIt it mbIt in if isJust mbIt && isEmpty res then ppCondTree ct Nothing ppIt else res where -- TODO: this ends up printing trailing spaces when combined with nest. ppIf (c,thenTree,mElseTree) = ((emptyLine $ text "if" <+> ppCondition c) $$ nest indentWith (ppCondTree thenTree (if simplifiedPrinting then (Just it) else Nothing) ppIt)) $+$ (if isNothing mElseTree then empty else text "else" $$ nest indentWith (ppCondTree (fromJust mElseTree) (if simplifiedPrinting then (Just it) else Nothing) ppIt)) emptyLine :: Doc -> Doc emptyLine d = text "" $+$ d Cabal-1.22.5.0/Distribution/PackageDescription/Utils.hs0000644000000000000000000000142012627136220020777 0ustar0000000000000000----------------------------------------------------------------------------- -- | -- Module : Distribution.PackageDescription.Utils -- -- Maintainer : cabal-devel@haskell.org -- Portability : portable -- -- Common utils used by modules under Distribution.PackageDescription.*. module Distribution.PackageDescription.Utils ( cabalBug, userBug ) where -- ---------------------------------------------------------------------------- -- Exception and logging utils userBug :: String -> a userBug msg = error $ msg ++ ". This is a bug in your .cabal file." cabalBug :: String -> a cabalBug msg = error $ msg ++ ". This is possibly a bug in Cabal.\n" ++ "Please report it to the developers: " ++ "https://github.com/haskell/cabal/issues/new" Cabal-1.22.5.0/Distribution/Simple/0000755000000000000000000000000012627136220015040 5ustar0000000000000000Cabal-1.22.5.0/Distribution/Simple/Bench.hs0000644000000000000000000001305412627136220016416 0ustar0000000000000000----------------------------------------------------------------------------- -- | -- Module : Distribution.Simple.Bench -- Copyright : Johan Tibell 2011 -- License : BSD3 -- -- Maintainer : cabal-devel@haskell.org -- Portability : portable -- -- This is the entry point into running the benchmarks in a built -- package. It performs the \"@.\/setup bench@\" action. It runs -- benchmarks designated in the package description. module Distribution.Simple.Bench ( bench ) where import qualified Distribution.PackageDescription as PD ( PackageDescription(..), BuildInfo(buildable) , Benchmark(..), BenchmarkInterface(..), benchmarkType, hasBenchmarks ) import Distribution.Simple.BuildPaths ( exeExtension ) import Distribution.Simple.Compiler ( compilerInfo ) import Distribution.Simple.InstallDirs ( fromPathTemplate, initialPathTemplateEnv, PathTemplateVariable(..) , substPathTemplate , toPathTemplate, PathTemplate ) import qualified Distribution.Simple.LocalBuildInfo as LBI ( LocalBuildInfo(..) ) import Distribution.Simple.Setup ( BenchmarkFlags(..), fromFlag ) import Distribution.Simple.UserHooks ( Args ) import Distribution.Simple.Utils ( die, notice, rawSystemExitCode ) import Distribution.Text import Control.Monad ( when, unless ) import System.Exit ( ExitCode(..), exitFailure, exitWith ) import System.Directory ( doesFileExist ) import System.FilePath ( (), (<.>) ) -- | Perform the \"@.\/setup bench@\" action. bench :: Args -- ^positional command-line arguments -> PD.PackageDescription -- ^information from the .cabal file -> LBI.LocalBuildInfo -- ^information from the configure step -> BenchmarkFlags -- ^flags sent to benchmark -> IO () bench args pkg_descr lbi flags = do let verbosity = fromFlag $ benchmarkVerbosity flags benchmarkNames = args pkgBenchmarks = PD.benchmarks pkg_descr enabledBenchmarks = [ t | t <- pkgBenchmarks , PD.benchmarkEnabled t , PD.buildable (PD.benchmarkBuildInfo t) ] -- Run the benchmark doBench :: PD.Benchmark -> IO ExitCode doBench bm = case PD.benchmarkInterface bm of PD.BenchmarkExeV10 _ _ -> do let cmd = LBI.buildDir lbi PD.benchmarkName bm PD.benchmarkName bm <.> exeExtension options = map (benchOption pkg_descr lbi bm) $ benchmarkOptions flags name = PD.benchmarkName bm -- Check that the benchmark executable exists. exists <- doesFileExist cmd unless exists $ die $ "Error: Could not find benchmark program \"" ++ cmd ++ "\". Did you build the package first?" notice verbosity $ startMessage name -- This will redirect the child process -- stdout/stderr to the parent process. exitcode <- rawSystemExitCode verbosity cmd options notice verbosity $ finishMessage name exitcode return exitcode _ -> do notice verbosity $ "No support for running " ++ "benchmark " ++ PD.benchmarkName bm ++ " of type: " ++ show (disp $ PD.benchmarkType bm) exitFailure when (not $ PD.hasBenchmarks pkg_descr) $ do notice verbosity "Package has no benchmarks." exitWith ExitSuccess when (PD.hasBenchmarks pkg_descr && null enabledBenchmarks) $ die $ "No benchmarks enabled. Did you remember to configure with " ++ "\'--enable-benchmarks\'?" bmsToRun <- case benchmarkNames of [] -> return enabledBenchmarks names -> flip mapM names $ \bmName -> let benchmarkMap = zip enabledNames enabledBenchmarks enabledNames = map PD.benchmarkName enabledBenchmarks allNames = map PD.benchmarkName pkgBenchmarks in case lookup bmName benchmarkMap of Just t -> return t _ | bmName `elem` allNames -> die $ "Package configured with benchmark " ++ bmName ++ " disabled." | otherwise -> die $ "no such benchmark: " ++ bmName let totalBenchmarks = length bmsToRun notice verbosity $ "Running " ++ show totalBenchmarks ++ " benchmarks..." exitcodes <- mapM doBench bmsToRun let allOk = totalBenchmarks == length (filter (== ExitSuccess) exitcodes) unless allOk exitFailure where startMessage name = "Benchmark " ++ name ++ ": RUNNING...\n" finishMessage name exitcode = "Benchmark " ++ name ++ ": " ++ (case exitcode of ExitSuccess -> "FINISH" ExitFailure _ -> "ERROR") -- TODO: This is abusing the notion of a 'PathTemplate'. The result isn't -- necessarily a path. benchOption :: PD.PackageDescription -> LBI.LocalBuildInfo -> PD.Benchmark -> PathTemplate -> String benchOption pkg_descr lbi bm template = fromPathTemplate $ substPathTemplate env template where env = initialPathTemplateEnv (PD.package pkg_descr) (LBI.pkgKey lbi) (compilerInfo $ LBI.compiler lbi) (LBI.hostPlatform lbi) ++ [(BenchmarkNameVar, toPathTemplate $ PD.benchmarkName bm)] Cabal-1.22.5.0/Distribution/Simple/Build.hs0000644000000000000000000006325512627136220016446 0ustar0000000000000000----------------------------------------------------------------------------- -- | -- Module : Distribution.Simple.Build -- Copyright : Isaac Jones 2003-2005, -- Ross Paterson 2006, -- Duncan Coutts 2007-2008, 2012 -- License : BSD3 -- -- Maintainer : cabal-devel@haskell.org -- Portability : portable -- -- This is the entry point to actually building the modules in a package. It -- doesn't actually do much itself, most of the work is delegated to -- compiler-specific actions. It does do some non-compiler specific bits like -- running pre-processors. -- module Distribution.Simple.Build ( build, repl, startInterpreter, initialBuildSteps, writeAutogenFiles, ) where import qualified Distribution.Simple.GHC as GHC import qualified Distribution.Simple.GHCJS as GHCJS import qualified Distribution.Simple.JHC as JHC import qualified Distribution.Simple.LHC as LHC import qualified Distribution.Simple.UHC as UHC import qualified Distribution.Simple.HaskellSuite as HaskellSuite import qualified Distribution.Simple.Build.Macros as Build.Macros import qualified Distribution.Simple.Build.PathsModule as Build.PathsModule import Distribution.Package ( Package(..), PackageName(..), PackageIdentifier(..) , Dependency(..), thisPackageVersion, mkPackageKey, packageName ) import Distribution.Simple.Compiler ( Compiler, CompilerFlavor(..), compilerFlavor , PackageDB(..), PackageDBStack, packageKeySupported ) import Distribution.PackageDescription ( PackageDescription(..), BuildInfo(..), Library(..), Executable(..) , TestSuite(..), TestSuiteInterface(..), Benchmark(..) , BenchmarkInterface(..), defaultRenaming ) import qualified Distribution.InstalledPackageInfo as IPI import qualified Distribution.ModuleName as ModuleName import Distribution.ModuleName (ModuleName) import Distribution.Simple.Setup ( Flag(..), BuildFlags(..), ReplFlags(..), fromFlag ) import Distribution.Simple.BuildTarget ( BuildTarget(..), readBuildTargets ) import Distribution.Simple.PreProcess ( preprocessComponent, PPSuffixHandler ) import Distribution.Simple.LocalBuildInfo ( LocalBuildInfo(compiler, buildDir, withPackageDB, withPrograms, pkgKey) , Component(..), componentName, getComponent, componentBuildInfo , ComponentLocalBuildInfo(..), pkgEnabledComponents , withComponentsInBuildOrder, componentsInBuildOrder , ComponentName(..), showComponentName , ComponentDisabledReason(..), componentDisabledReason , inplacePackageId, LibraryName(..) ) import Distribution.Simple.Program.Types import Distribution.Simple.Program.Db import qualified Distribution.Simple.Program.HcPkg as HcPkg import Distribution.Simple.BuildPaths ( autogenModulesDir, autogenModuleName, cppHeaderName, exeExtension ) import Distribution.Simple.Register ( registerPackage, inplaceInstalledPackageInfo ) import Distribution.Simple.Test.LibV09 ( stubFilePath, stubName ) import Distribution.Simple.Utils ( createDirectoryIfMissingVerbose, rewriteFile , die, info, debug, warn, setupMessage ) import Distribution.Verbosity ( Verbosity ) import Distribution.Text ( display ) import qualified Data.Map as Map import Data.Maybe ( maybeToList ) import Data.Either ( partitionEithers ) import Data.List ( intersect, intercalate ) import Control.Monad ( when, unless, forM_ ) import System.FilePath ( (), (<.>) ) import System.Directory ( getCurrentDirectory, removeDirectoryRecursive, removeFile , doesDirectoryExist, doesFileExist ) -- ----------------------------------------------------------------------------- -- |Build the libraries and executables in this package. build :: PackageDescription -- ^ Mostly information from the .cabal file -> LocalBuildInfo -- ^ Configuration information -> BuildFlags -- ^ Flags that the user passed to build -> [ PPSuffixHandler ] -- ^ preprocessors to run before compiling -> IO () build pkg_descr lbi flags suffixes = do let distPref = fromFlag (buildDistPref flags) verbosity = fromFlag (buildVerbosity flags) targets <- readBuildTargets pkg_descr (buildArgs flags) targets' <- checkBuildTargets verbosity pkg_descr targets let componentsToBuild = map fst (componentsInBuildOrder lbi (map fst targets')) info verbosity $ "Component build order: " ++ intercalate ", " (map showComponentName componentsToBuild) initialBuildSteps distPref pkg_descr lbi verbosity when (null targets) $ -- Only bother with this message if we're building the whole package setupMessage verbosity "Building" (packageId pkg_descr) internalPackageDB <- createInternalPackageDB verbosity lbi distPref withComponentsInBuildOrder pkg_descr lbi componentsToBuild $ \comp clbi -> let bi = componentBuildInfo comp progs' = addInternalBuildTools pkg_descr lbi bi (withPrograms lbi) lbi' = lbi { withPrograms = progs', withPackageDB = withPackageDB lbi ++ [internalPackageDB] } in buildComponent verbosity (buildNumJobs flags) pkg_descr lbi' suffixes comp clbi distPref repl :: PackageDescription -- ^ Mostly information from the .cabal file -> LocalBuildInfo -- ^ Configuration information -> ReplFlags -- ^ Flags that the user passed to build -> [ PPSuffixHandler ] -- ^ preprocessors to run before compiling -> [String] -> IO () repl pkg_descr lbi flags suffixes args = do let distPref = fromFlag (replDistPref flags) verbosity = fromFlag (replVerbosity flags) targets <- readBuildTargets pkg_descr args targets' <- case targets of [] -> return $ take 1 [ componentName c | c <- pkgEnabledComponents pkg_descr ] [target] -> fmap (map fst) (checkBuildTargets verbosity pkg_descr [target]) _ -> die $ "The 'repl' command does not support multiple targets at once." let componentsToBuild = componentsInBuildOrder lbi targets' componentForRepl = last componentsToBuild debug verbosity $ "Component build order: " ++ intercalate ", " [ showComponentName c | (c,_) <- componentsToBuild ] initialBuildSteps distPref pkg_descr lbi verbosity internalPackageDB <- createInternalPackageDB verbosity lbi distPref let lbiForComponent comp lbi' = lbi' { withPackageDB = withPackageDB lbi ++ [internalPackageDB], withPrograms = addInternalBuildTools pkg_descr lbi' (componentBuildInfo comp) (withPrograms lbi') } -- build any dependent components sequence_ [ let comp = getComponent pkg_descr cname lbi' = lbiForComponent comp lbi in buildComponent verbosity NoFlag pkg_descr lbi' suffixes comp clbi distPref | (cname, clbi) <- init componentsToBuild ] -- REPL for target components let (cname, clbi) = componentForRepl comp = getComponent pkg_descr cname lbi' = lbiForComponent comp lbi in replComponent verbosity pkg_descr lbi' suffixes comp clbi distPref -- | Start an interpreter without loading any package files. startInterpreter :: Verbosity -> ProgramDb -> Compiler -> PackageDBStack -> IO () startInterpreter verbosity programDb comp packageDBs = case compilerFlavor comp of GHC -> GHC.startInterpreter verbosity programDb comp packageDBs GHCJS -> GHCJS.startInterpreter verbosity programDb comp packageDBs _ -> die "A REPL is not supported with this compiler." buildComponent :: Verbosity -> Flag (Maybe Int) -> PackageDescription -> LocalBuildInfo -> [PPSuffixHandler] -> Component -> ComponentLocalBuildInfo -> FilePath -> IO () buildComponent verbosity numJobs pkg_descr lbi suffixes comp@(CLib lib) clbi distPref = do preprocessComponent pkg_descr comp lbi False verbosity suffixes info verbosity "Building library..." buildLib verbosity numJobs pkg_descr lbi lib clbi -- Register the library in-place, so exes can depend -- on internally defined libraries. pwd <- getCurrentDirectory let -- The in place registration uses the "-inplace" suffix, not an ABI hash ipkgid = inplacePackageId (packageId installedPkgInfo) installedPkgInfo = inplaceInstalledPackageInfo pwd distPref pkg_descr ipkgid lib lbi clbi registerPackage verbosity installedPkgInfo pkg_descr lbi True -- True meaning in place (withPackageDB lbi) buildComponent verbosity numJobs pkg_descr lbi suffixes comp@(CExe exe) clbi _ = do preprocessComponent pkg_descr comp lbi False verbosity suffixes info verbosity $ "Building executable " ++ exeName exe ++ "..." buildExe verbosity numJobs pkg_descr lbi exe clbi buildComponent verbosity numJobs pkg_descr lbi suffixes comp@(CTest test@TestSuite { testInterface = TestSuiteExeV10{} }) clbi _distPref = do let exe = testSuiteExeV10AsExe test preprocessComponent pkg_descr comp lbi False verbosity suffixes info verbosity $ "Building test suite " ++ testName test ++ "..." buildExe verbosity numJobs pkg_descr lbi exe clbi buildComponent verbosity numJobs pkg_descr lbi0 suffixes comp@(CTest test@TestSuite { testInterface = TestSuiteLibV09{} }) clbi -- This ComponentLocalBuildInfo corresponds to a detailed -- test suite and not a real component. It should not -- be used, except to construct the CLBIs for the -- library and stub executable that will actually be -- built. distPref = do pwd <- getCurrentDirectory let (pkg, lib, libClbi, lbi, ipi, exe, exeClbi) = testSuiteLibV09AsLibAndExe pkg_descr test clbi lbi0 distPref pwd preprocessComponent pkg_descr comp lbi False verbosity suffixes info verbosity $ "Building test suite " ++ testName test ++ "..." buildLib verbosity numJobs pkg lbi lib libClbi registerPackage verbosity ipi pkg lbi True $ withPackageDB lbi buildExe verbosity numJobs pkg_descr lbi exe exeClbi buildComponent _ _ _ _ _ (CTest TestSuite { testInterface = TestSuiteUnsupported tt }) _ _ = die $ "No support for building test suite type " ++ display tt buildComponent verbosity numJobs pkg_descr lbi suffixes comp@(CBench bm@Benchmark { benchmarkInterface = BenchmarkExeV10 {} }) clbi _ = do let (exe, exeClbi) = benchmarkExeV10asExe bm clbi preprocessComponent pkg_descr comp lbi False verbosity suffixes info verbosity $ "Building benchmark " ++ benchmarkName bm ++ "..." buildExe verbosity numJobs pkg_descr lbi exe exeClbi buildComponent _ _ _ _ _ (CBench Benchmark { benchmarkInterface = BenchmarkUnsupported tt }) _ _ = die $ "No support for building benchmark type " ++ display tt replComponent :: Verbosity -> PackageDescription -> LocalBuildInfo -> [PPSuffixHandler] -> Component -> ComponentLocalBuildInfo -> FilePath -> IO () replComponent verbosity pkg_descr lbi suffixes comp@(CLib lib) clbi _ = do preprocessComponent pkg_descr comp lbi False verbosity suffixes replLib verbosity pkg_descr lbi lib clbi replComponent verbosity pkg_descr lbi suffixes comp@(CExe exe) clbi _ = do preprocessComponent pkg_descr comp lbi False verbosity suffixes replExe verbosity pkg_descr lbi exe clbi replComponent verbosity pkg_descr lbi suffixes comp@(CTest test@TestSuite { testInterface = TestSuiteExeV10{} }) clbi _distPref = do let exe = testSuiteExeV10AsExe test preprocessComponent pkg_descr comp lbi False verbosity suffixes replExe verbosity pkg_descr lbi exe clbi replComponent verbosity pkg_descr lbi0 suffixes comp@(CTest test@TestSuite { testInterface = TestSuiteLibV09{} }) clbi distPref = do pwd <- getCurrentDirectory let (pkg, lib, libClbi, lbi, _, _, _) = testSuiteLibV09AsLibAndExe pkg_descr test clbi lbi0 distPref pwd preprocessComponent pkg_descr comp lbi False verbosity suffixes replLib verbosity pkg lbi lib libClbi replComponent _ _ _ _ (CTest TestSuite { testInterface = TestSuiteUnsupported tt }) _ _ = die $ "No support for building test suite type " ++ display tt replComponent verbosity pkg_descr lbi suffixes comp@(CBench bm@Benchmark { benchmarkInterface = BenchmarkExeV10 {} }) clbi _ = do let (exe, exeClbi) = benchmarkExeV10asExe bm clbi preprocessComponent pkg_descr comp lbi False verbosity suffixes replExe verbosity pkg_descr lbi exe exeClbi replComponent _ _ _ _ (CBench Benchmark { benchmarkInterface = BenchmarkUnsupported tt }) _ _ = die $ "No support for building benchmark type " ++ display tt ---------------------------------------------------- -- Shared code for buildComponent and replComponent -- -- | Translate a exe-style 'TestSuite' component into an exe for building testSuiteExeV10AsExe :: TestSuite -> Executable testSuiteExeV10AsExe test@TestSuite { testInterface = TestSuiteExeV10 _ mainFile } = Executable { exeName = testName test, modulePath = mainFile, buildInfo = testBuildInfo test } testSuiteExeV10AsExe TestSuite{} = error "testSuiteExeV10AsExe: wrong kind" -- | Translate a lib-style 'TestSuite' component into a lib + exe for building testSuiteLibV09AsLibAndExe :: PackageDescription -> TestSuite -> ComponentLocalBuildInfo -> LocalBuildInfo -> FilePath -> FilePath -> (PackageDescription, Library, ComponentLocalBuildInfo, LocalBuildInfo, IPI.InstalledPackageInfo_ ModuleName, Executable, ComponentLocalBuildInfo) testSuiteLibV09AsLibAndExe pkg_descr test@TestSuite { testInterface = TestSuiteLibV09 _ m } clbi lbi distPref pwd = (pkg, lib, libClbi, lbi', ipi, exe, exeClbi) where bi = testBuildInfo test lib = Library { exposedModules = [ m ], reexportedModules = [], requiredSignatures = [], exposedSignatures = [], libExposed = True, libBuildInfo = bi } libClbi = LibComponentLocalBuildInfo { componentPackageDeps = componentPackageDeps clbi , componentPackageRenaming = componentPackageRenaming clbi , componentLibraries = [LibraryName (testName test)] , componentExposedModules = [IPI.ExposedModule m Nothing Nothing] } pkg = pkg_descr { package = (package pkg_descr) { pkgName = PackageName (testName test) } , buildDepends = targetBuildDepends $ testBuildInfo test , executables = [] , testSuites = [] , library = Just lib } -- Hack to make the library compile with the right package key. -- Probably the "right" way to do this is move this information to -- the ComponentLocalBuildInfo, but it seems odd that a single package -- can define multiple actual packages. lbi' = lbi { pkgKey = mkPackageKey (packageKeySupported (compiler lbi)) (package pkg) [] [] } ipkgid = inplacePackageId (packageId pkg) ipi = inplaceInstalledPackageInfo pwd distPref pkg ipkgid lib lbi' libClbi testDir = buildDir lbi stubName test stubName test ++ "-tmp" testLibDep = thisPackageVersion $ package pkg exe = Executable { exeName = stubName test, modulePath = stubFilePath test, buildInfo = (testBuildInfo test) { hsSourceDirs = [ testDir ], targetBuildDepends = testLibDep : (targetBuildDepends $ testBuildInfo test), targetBuildRenaming = Map.insert (packageName pkg) defaultRenaming (targetBuildRenaming $ testBuildInfo test) } } -- | The stub executable needs a new 'ComponentLocalBuildInfo' -- that exposes the relevant test suite library. exeClbi = ExeComponentLocalBuildInfo { componentPackageDeps = (IPI.installedPackageId ipi, packageId ipi) : (filter (\(_, x) -> let PackageName name = pkgName x in name == "Cabal" || name == "base") (componentPackageDeps clbi)), componentPackageRenaming = Map.insert (packageName ipi) defaultRenaming (componentPackageRenaming clbi) } testSuiteLibV09AsLibAndExe _ TestSuite{} _ _ _ _ = error "testSuiteLibV09AsLibAndExe: wrong kind" -- | Translate a exe-style 'Benchmark' component into an exe for building benchmarkExeV10asExe :: Benchmark -> ComponentLocalBuildInfo -> (Executable, ComponentLocalBuildInfo) benchmarkExeV10asExe bm@Benchmark { benchmarkInterface = BenchmarkExeV10 _ f } clbi = (exe, exeClbi) where exe = Executable { exeName = benchmarkName bm, modulePath = f, buildInfo = benchmarkBuildInfo bm } exeClbi = ExeComponentLocalBuildInfo { componentPackageDeps = componentPackageDeps clbi, componentPackageRenaming = componentPackageRenaming clbi } benchmarkExeV10asExe Benchmark{} _ = error "benchmarkExeV10asExe: wrong kind" -- | Initialize a new package db file for libraries defined -- internally to the package. createInternalPackageDB :: Verbosity -> LocalBuildInfo -> FilePath -> IO PackageDB createInternalPackageDB verbosity lbi distPref = do case compilerFlavor (compiler lbi) of GHC -> createWith $ GHC.hcPkgInfo (withPrograms lbi) GHCJS -> createWith $ GHCJS.hcPkgInfo (withPrograms lbi) LHC -> createWith $ LHC.hcPkgInfo (withPrograms lbi) _ -> return packageDB where dbPath = distPref "package.conf.inplace" packageDB = SpecificPackageDB dbPath createWith hpi = do dir_exists <- doesDirectoryExist dbPath if dir_exists then removeDirectoryRecursive dbPath else do file_exists <- doesFileExist dbPath when file_exists $ removeFile dbPath if HcPkg.useSingleFileDb hpi then writeFile dbPath "[]" else HcPkg.init hpi verbosity dbPath return packageDB addInternalBuildTools :: PackageDescription -> LocalBuildInfo -> BuildInfo -> ProgramDb -> ProgramDb addInternalBuildTools pkg lbi bi progs = foldr updateProgram progs internalBuildTools where internalBuildTools = [ simpleConfiguredProgram toolName (FoundOnSystem toolLocation) | toolName <- toolNames , let toolLocation = buildDir lbi toolName toolName <.> exeExtension ] toolNames = intersect buildToolNames internalExeNames internalExeNames = map exeName (executables pkg) buildToolNames = map buildToolName (buildTools bi) where buildToolName (Dependency (PackageName name) _ ) = name -- TODO: build separate libs in separate dirs so that we can build -- multiple libs, e.g. for 'LibTest' library-style test suites buildLib :: Verbosity -> Flag (Maybe Int) -> PackageDescription -> LocalBuildInfo -> Library -> ComponentLocalBuildInfo -> IO () buildLib verbosity numJobs pkg_descr lbi lib clbi = case compilerFlavor (compiler lbi) of GHC -> GHC.buildLib verbosity numJobs pkg_descr lbi lib clbi GHCJS -> GHCJS.buildLib verbosity numJobs pkg_descr lbi lib clbi JHC -> JHC.buildLib verbosity pkg_descr lbi lib clbi LHC -> LHC.buildLib verbosity pkg_descr lbi lib clbi UHC -> UHC.buildLib verbosity pkg_descr lbi lib clbi HaskellSuite {} -> HaskellSuite.buildLib verbosity pkg_descr lbi lib clbi _ -> die "Building is not supported with this compiler." buildExe :: Verbosity -> Flag (Maybe Int) -> PackageDescription -> LocalBuildInfo -> Executable -> ComponentLocalBuildInfo -> IO () buildExe verbosity numJobs pkg_descr lbi exe clbi = case compilerFlavor (compiler lbi) of GHC -> GHC.buildExe verbosity numJobs pkg_descr lbi exe clbi GHCJS -> GHCJS.buildExe verbosity numJobs pkg_descr lbi exe clbi JHC -> JHC.buildExe verbosity pkg_descr lbi exe clbi LHC -> LHC.buildExe verbosity pkg_descr lbi exe clbi UHC -> UHC.buildExe verbosity pkg_descr lbi exe clbi _ -> die "Building is not supported with this compiler." replLib :: Verbosity -> PackageDescription -> LocalBuildInfo -> Library -> ComponentLocalBuildInfo -> IO () replLib verbosity pkg_descr lbi lib clbi = case compilerFlavor (compiler lbi) of -- 'cabal repl' doesn't need to support 'ghc --make -j', so we just pass -- NoFlag as the numJobs parameter. GHC -> GHC.replLib verbosity NoFlag pkg_descr lbi lib clbi GHCJS -> GHCJS.replLib verbosity NoFlag pkg_descr lbi lib clbi _ -> die "A REPL is not supported for this compiler." replExe :: Verbosity -> PackageDescription -> LocalBuildInfo -> Executable -> ComponentLocalBuildInfo -> IO () replExe verbosity pkg_descr lbi exe clbi = case compilerFlavor (compiler lbi) of GHC -> GHC.replExe verbosity NoFlag pkg_descr lbi exe clbi GHCJS -> GHCJS.replExe verbosity NoFlag pkg_descr lbi exe clbi _ -> die "A REPL is not supported for this compiler." initialBuildSteps :: FilePath -- ^"dist" prefix -> PackageDescription -- ^mostly information from the .cabal file -> LocalBuildInfo -- ^Configuration information -> Verbosity -- ^The verbosity to use -> IO () initialBuildSteps _distPref pkg_descr lbi verbosity = do -- check that there's something to build let buildInfos = map libBuildInfo (maybeToList (library pkg_descr)) ++ map buildInfo (executables pkg_descr) unless (any buildable buildInfos) $ do let name = display (packageId pkg_descr) die ("Package " ++ name ++ " can't be built on this system.") createDirectoryIfMissingVerbose verbosity True (buildDir lbi) writeAutogenFiles verbosity pkg_descr lbi -- | Generate and write out the Paths_.hs and cabal_macros.h files -- writeAutogenFiles :: Verbosity -> PackageDescription -> LocalBuildInfo -> IO () writeAutogenFiles verbosity pkg lbi = do createDirectoryIfMissingVerbose verbosity True (autogenModulesDir lbi) let pathsModulePath = autogenModulesDir lbi ModuleName.toFilePath (autogenModuleName pkg) <.> "hs" rewriteFile pathsModulePath (Build.PathsModule.generate pkg lbi) let cppHeaderPath = autogenModulesDir lbi cppHeaderName rewriteFile cppHeaderPath (Build.Macros.generate pkg lbi) -- | Check that the given build targets are valid in the current context. -- -- Also swizzle into a more convenient form. -- checkBuildTargets :: Verbosity -> PackageDescription -> [BuildTarget] -> IO [(ComponentName, Maybe (Either ModuleName FilePath))] checkBuildTargets _ pkg [] = return [ (componentName c, Nothing) | c <- pkgEnabledComponents pkg ] checkBuildTargets verbosity pkg targets = do let (enabled, disabled) = partitionEithers [ case componentDisabledReason (getComponent pkg cname) of Nothing -> Left target' Just reason -> Right (cname, reason) | target <- targets , let target'@(cname,_) = swizzleTarget target ] case disabled of [] -> return () ((cname,reason):_) -> die $ formatReason (showComponentName cname) reason forM_ [ (c, t) | (c, Just t) <- enabled ] $ \(c, t) -> warn verbosity $ "Ignoring '" ++ either display id t ++ ". The whole " ++ showComponentName c ++ " will be built. (Support for " ++ "module and file targets has not been implemented yet.)" return enabled where swizzleTarget (BuildTargetComponent c) = (c, Nothing) swizzleTarget (BuildTargetModule c m) = (c, Just (Left m)) swizzleTarget (BuildTargetFile c f) = (c, Just (Right f)) formatReason cn DisabledComponent = "Cannot build the " ++ cn ++ " because the component is marked " ++ "as disabled in the .cabal file." formatReason cn DisabledAllTests = "Cannot build the " ++ cn ++ " because test suites are not " ++ "enabled. Run configure with the flag --enable-tests" formatReason cn DisabledAllBenchmarks = "Cannot build the " ++ cn ++ " because benchmarks are not " ++ "enabled. Re-run configure with the flag --enable-benchmarks" Cabal-1.22.5.0/Distribution/Simple/BuildPaths.hs0000644000000000000000000000745412627136220017445 0ustar0000000000000000----------------------------------------------------------------------------- -- | -- Module : Distribution.Simple.BuildPaths -- Copyright : Isaac Jones 2003-2004, -- Duncan Coutts 2008 -- License : BSD3 -- -- Maintainer : cabal-devel@haskell.org -- Portability : portable -- -- A bunch of dirs, paths and file names used for intermediate build steps. -- module Distribution.Simple.BuildPaths ( defaultDistPref, srcPref, hscolourPref, haddockPref, autogenModulesDir, autogenModuleName, cppHeaderName, haddockName, mkLibName, mkProfLibName, mkSharedLibName, exeExtension, objExtension, dllExtension, ) where import System.FilePath ((), (<.>)) import Distribution.Package ( packageName ) import Distribution.ModuleName (ModuleName) import qualified Distribution.ModuleName as ModuleName import Distribution.Compiler ( CompilerId(..) ) import Distribution.PackageDescription (PackageDescription) import Distribution.Simple.LocalBuildInfo ( LocalBuildInfo(buildDir), LibraryName(..) ) import Distribution.Simple.Setup (defaultDistPref) import Distribution.Text ( display ) import Distribution.System (OS(..), buildOS) -- --------------------------------------------------------------------------- -- Build directories and files srcPref :: FilePath -> FilePath srcPref distPref = distPref "src" hscolourPref :: FilePath -> PackageDescription -> FilePath hscolourPref = haddockPref haddockPref :: FilePath -> PackageDescription -> FilePath haddockPref distPref pkg_descr = distPref "doc" "html" display (packageName pkg_descr) -- |The directory in which we put auto-generated modules autogenModulesDir :: LocalBuildInfo -> String autogenModulesDir lbi = buildDir lbi "autogen" cppHeaderName :: String cppHeaderName = "cabal_macros.h" -- |The name of the auto-generated module associated with a package autogenModuleName :: PackageDescription -> ModuleName autogenModuleName pkg_descr = ModuleName.fromString $ "Paths_" ++ map fixchar (display (packageName pkg_descr)) where fixchar '-' = '_' fixchar c = c haddockName :: PackageDescription -> FilePath haddockName pkg_descr = display (packageName pkg_descr) <.> "haddock" -- --------------------------------------------------------------------------- -- Library file names mkLibName :: LibraryName -> String mkLibName (LibraryName lib) = "lib" ++ lib <.> "a" mkProfLibName :: LibraryName -> String mkProfLibName (LibraryName lib) = "lib" ++ lib ++ "_p" <.> "a" -- Implement proper name mangling for dynamical shared objects -- libHS- -- e.g. libHSbase-2.1-ghc6.6.1.so mkSharedLibName :: CompilerId -> LibraryName -> String mkSharedLibName (CompilerId compilerFlavor compilerVersion) (LibraryName lib) = "lib" ++ lib ++ "-" ++ comp <.> dllExtension where comp = display compilerFlavor ++ display compilerVersion -- ------------------------------------------------------------ -- * Platform file extensions -- ------------------------------------------------------------ -- ToDo: This should be determined via autoconf (AC_EXEEXT) -- | Extension for executable files -- (typically @\"\"@ on Unix and @\"exe\"@ on Windows or OS\/2) exeExtension :: String exeExtension = case buildOS of Windows -> "exe" _ -> "" -- TODO: This should be determined via autoconf (AC_OBJEXT) -- | Extension for object files. For GHC the extension is @\"o\"@. objExtension :: String objExtension = "o" -- | Extension for dynamically linked (or shared) libraries -- (typically @\"so\"@ on Unix and @\"dll\"@ on Windows) dllExtension :: String dllExtension = case buildOS of Windows -> "dll" OSX -> "dylib" _ -> "so" Cabal-1.22.5.0/Distribution/Simple/BuildTarget.hs0000644000000000000000000007774112627136220017622 0ustar0000000000000000{-# LANGUAGE CPP #-} ----------------------------------------------------------------------------- -- | -- Module : Distribution.Client.BuildTargets -- Copyright : (c) Duncan Coutts 2012 -- License : BSD-like -- -- Maintainer : duncan@community.haskell.org -- -- Handling for user-specified build targets ----------------------------------------------------------------------------- module Distribution.Simple.BuildTarget ( -- * Build targets BuildTarget(..), readBuildTargets, -- * Parsing user build targets UserBuildTarget, readUserBuildTargets, UserBuildTargetProblem(..), reportUserBuildTargetProblems, -- * Resolving build targets resolveBuildTargets, BuildTargetProblem(..), reportBuildTargetProblems, ) where import Distribution.Package ( Package(..), PackageId, packageName ) import Distribution.PackageDescription ( PackageDescription , Executable(..) , TestSuite(..), TestSuiteInterface(..), testModules , Benchmark(..), BenchmarkInterface(..), benchmarkModules , BuildInfo(..), libModules, exeModules ) import Distribution.ModuleName ( ModuleName, toFilePath ) import Distribution.Simple.LocalBuildInfo ( Component(..), ComponentName(..) , pkgComponents, componentName, componentBuildInfo ) import Distribution.Text ( display ) import Distribution.Simple.Utils ( die, lowercase, equating ) import Data.List ( nub, stripPrefix, sortBy, groupBy, partition, intercalate ) import Data.Ord import Data.Maybe ( listToMaybe, catMaybes ) import Data.Either ( partitionEithers ) import qualified Data.Map as Map import Control.Monad #if __GLASGOW_HASKELL__ < 710 import Control.Applicative (Applicative(..)) #endif import Control.Applicative (Alternative(..)) import qualified Distribution.Compat.ReadP as Parse import Distribution.Compat.ReadP ( (+++), (<++) ) import Data.Char ( isSpace, isAlphaNum ) import System.FilePath as FilePath ( dropExtension, normalise, splitDirectories, joinPath, splitPath , hasTrailingPathSeparator ) import System.Directory ( doesFileExist, doesDirectoryExist ) -- ------------------------------------------------------------ -- * User build targets -- ------------------------------------------------------------ -- | Various ways that a user may specify a build target. -- data UserBuildTarget = -- | A target specified by a single name. This could be a component -- module or file. -- -- > cabal build foo -- > cabal build Data.Foo -- > cabal build Data/Foo.hs Data/Foo.hsc -- UserBuildTargetSingle String -- | A target specified by a qualifier and name. This could be a component -- name qualified by the component namespace kind, or a module or file -- qualified by the component name. -- -- > cabal build lib:foo exe:foo -- > cabal build foo:Data.Foo -- > cabal build foo:Data/Foo.hs -- | UserBuildTargetDouble String String -- A fully qualified target, either a module or file qualified by a -- component name with the component namespace kind. -- -- > cabal build lib:foo:Data/Foo.hs exe:foo:Data/Foo.hs -- > cabal build lib:foo:Data.Foo exe:foo:Data.Foo -- | UserBuildTargetTriple String String String deriving (Show, Eq, Ord) -- ------------------------------------------------------------ -- * Resolved build targets -- ------------------------------------------------------------ -- | A fully resolved build target. -- data BuildTarget = -- | A specific component -- BuildTargetComponent ComponentName -- | A specific module within a specific component. -- | BuildTargetModule ComponentName ModuleName -- | A specific file within a specific component. -- | BuildTargetFile ComponentName FilePath deriving (Show,Eq) -- ------------------------------------------------------------ -- * Do everything -- ------------------------------------------------------------ readBuildTargets :: PackageDescription -> [String] -> IO [BuildTarget] readBuildTargets pkg targetStrs = do let (uproblems, utargets) = readUserBuildTargets targetStrs reportUserBuildTargetProblems uproblems utargets' <- mapM checkTargetExistsAsFile utargets let (bproblems, btargets) = resolveBuildTargets pkg utargets' reportBuildTargetProblems bproblems return btargets checkTargetExistsAsFile :: UserBuildTarget -> IO (UserBuildTarget, Bool) checkTargetExistsAsFile t = do fexists <- existsAsFile (fileComponentOfTarget t) return (t, fexists) where existsAsFile f = do exists <- doesFileExist f case splitPath f of (d:_) | hasTrailingPathSeparator d -> doesDirectoryExist d (d:_:_) | not exists -> doesDirectoryExist d _ -> return exists fileComponentOfTarget (UserBuildTargetSingle s1) = s1 fileComponentOfTarget (UserBuildTargetDouble _ s2) = s2 fileComponentOfTarget (UserBuildTargetTriple _ _ s3) = s3 -- ------------------------------------------------------------ -- * Parsing user targets -- ------------------------------------------------------------ readUserBuildTargets :: [String] -> ([UserBuildTargetProblem] ,[UserBuildTarget]) readUserBuildTargets = partitionEithers . map readUserBuildTarget readUserBuildTarget :: String -> Either UserBuildTargetProblem UserBuildTarget readUserBuildTarget targetstr = case readPToMaybe parseTargetApprox targetstr of Nothing -> Left (UserBuildTargetUnrecognised targetstr) Just tgt -> Right tgt where parseTargetApprox :: Parse.ReadP r UserBuildTarget parseTargetApprox = (do a <- tokenQ return (UserBuildTargetSingle a)) +++ (do a <- token _ <- Parse.char ':' b <- tokenQ return (UserBuildTargetDouble a b)) +++ (do a <- token _ <- Parse.char ':' b <- token _ <- Parse.char ':' c <- tokenQ return (UserBuildTargetTriple a b c)) token = Parse.munch1 (\x -> not (isSpace x) && x /= ':') tokenQ = parseHaskellString <++ token parseHaskellString :: Parse.ReadP r String parseHaskellString = Parse.readS_to_P reads readPToMaybe :: Parse.ReadP a a -> String -> Maybe a readPToMaybe p str = listToMaybe [ r | (r,s) <- Parse.readP_to_S p str , all isSpace s ] data UserBuildTargetProblem = UserBuildTargetUnrecognised String deriving Show reportUserBuildTargetProblems :: [UserBuildTargetProblem] -> IO () reportUserBuildTargetProblems problems = do case [ target | UserBuildTargetUnrecognised target <- problems ] of [] -> return () target -> die $ unlines [ "Unrecognised build target '" ++ name ++ "'." | name <- target ] ++ "Examples:\n" ++ " - build foo -- component name " ++ "(library, executable, test-suite or benchmark)\n" ++ " - build Data.Foo -- module name\n" ++ " - build Data/Foo.hsc -- file name\n" ++ " - build lib:foo exe:foo -- component qualified by kind\n" ++ " - build foo:Data.Foo -- module qualified by component\n" ++ " - build foo:Data/Foo.hsc -- file qualified by component" showUserBuildTarget :: UserBuildTarget -> String showUserBuildTarget = intercalate ":" . components where components (UserBuildTargetSingle s1) = [s1] components (UserBuildTargetDouble s1 s2) = [s1,s2] components (UserBuildTargetTriple s1 s2 s3) = [s1,s2,s3] -- ------------------------------------------------------------ -- * Resolving user targets to build targets -- ------------------------------------------------------------ {- stargets = [ BuildTargetComponent (CExeName "foo") , BuildTargetModule (CExeName "foo") (mkMn "Foo") , BuildTargetModule (CExeName "tst") (mkMn "Foo") ] where mkMn :: String -> ModuleName mkMn = fromJust . simpleParse ex_pkgid :: PackageIdentifier Just ex_pkgid = simpleParse "thelib" -} -- | Given a bunch of user-specified targets, try to resolve what it is they -- refer to. -- resolveBuildTargets :: PackageDescription -> [(UserBuildTarget, Bool)] -> ([BuildTargetProblem], [BuildTarget]) resolveBuildTargets pkg = partitionEithers . map (uncurry (resolveBuildTarget pkg)) resolveBuildTarget :: PackageDescription -> UserBuildTarget -> Bool -> Either BuildTargetProblem BuildTarget resolveBuildTarget pkg userTarget fexists = case findMatch (matchBuildTarget pkg userTarget fexists) of Unambiguous target -> Right target Ambiguous targets -> Left (BuildTargetAmbigious userTarget targets') where targets' = disambiguateBuildTargets (packageId pkg) userTarget targets None errs -> Left (classifyMatchErrors errs) where classifyMatchErrors errs | not (null expected) = let (things, got:_) = unzip expected in BuildTargetExpected userTarget things got | not (null nosuch) = BuildTargetNoSuch userTarget nosuch | otherwise = error $ "resolveBuildTarget: internal error in matching" where expected = [ (thing, got) | MatchErrorExpected thing got <- errs ] nosuch = [ (thing, got) | MatchErrorNoSuch thing got <- errs ] data BuildTargetProblem = BuildTargetExpected UserBuildTarget [String] String -- ^ [expected thing] (actually got) | BuildTargetNoSuch UserBuildTarget [(String, String)] -- ^ [(no such thing, actually got)] | BuildTargetAmbigious UserBuildTarget [(UserBuildTarget, BuildTarget)] deriving Show disambiguateBuildTargets :: PackageId -> UserBuildTarget -> [BuildTarget] -> [(UserBuildTarget, BuildTarget)] disambiguateBuildTargets pkgid original = disambiguate (userTargetQualLevel original) where disambiguate ql ts | null amb = unamb | otherwise = unamb ++ disambiguate (succ ql) amb where (amb, unamb) = step ql ts userTargetQualLevel (UserBuildTargetSingle _ ) = QL1 userTargetQualLevel (UserBuildTargetDouble _ _ ) = QL2 userTargetQualLevel (UserBuildTargetTriple _ _ _) = QL3 step :: QualLevel -> [BuildTarget] -> ([BuildTarget], [(UserBuildTarget, BuildTarget)]) step ql = (\(amb, unamb) -> (map snd $ concat amb, concat unamb)) . partition (\g -> length g > 1) . groupBy (equating fst) . sortBy (comparing fst) . map (\t -> (renderBuildTarget ql t pkgid, t)) data QualLevel = QL1 | QL2 | QL3 deriving (Enum, Show) renderBuildTarget :: QualLevel -> BuildTarget -> PackageId -> UserBuildTarget renderBuildTarget ql target pkgid = case ql of QL1 -> UserBuildTargetSingle s1 where s1 = single target QL2 -> UserBuildTargetDouble s1 s2 where (s1, s2) = double target QL3 -> UserBuildTargetTriple s1 s2 s3 where (s1, s2, s3) = triple target where single (BuildTargetComponent cn ) = dispCName cn single (BuildTargetModule _ m) = display m single (BuildTargetFile _ f) = f double (BuildTargetComponent cn ) = (dispKind cn, dispCName cn) double (BuildTargetModule cn m) = (dispCName cn, display m) double (BuildTargetFile cn f) = (dispCName cn, f) triple (BuildTargetComponent _ ) = error "triple BuildTargetComponent" triple (BuildTargetModule cn m) = (dispKind cn, dispCName cn, display m) triple (BuildTargetFile cn f) = (dispKind cn, dispCName cn, f) dispCName = componentStringName pkgid dispKind = showComponentKindShort . componentKind reportBuildTargetProblems :: [BuildTargetProblem] -> IO () reportBuildTargetProblems problems = do case [ (t, e, g) | BuildTargetExpected t e g <- problems ] of [] -> return () targets -> die $ unlines [ "Unrecognised build target '" ++ showUserBuildTarget target ++ "'.\n" ++ "Expected a " ++ intercalate " or " expected ++ ", rather than '" ++ got ++ "'." | (target, expected, got) <- targets ] case [ (t, e) | BuildTargetNoSuch t e <- problems ] of [] -> return () targets -> die $ unlines [ "Unknown build target '" ++ showUserBuildTarget target ++ "'.\nThere is no " ++ intercalate " or " [ mungeThing thing ++ " '" ++ got ++ "'" | (thing, got) <- nosuch ] ++ "." | (target, nosuch) <- targets ] where mungeThing "file" = "file target" mungeThing thing = thing case [ (t, ts) | BuildTargetAmbigious t ts <- problems ] of [] -> return () targets -> die $ unlines [ "Ambiguous build target '" ++ showUserBuildTarget target ++ "'. It could be:\n " ++ unlines [ " "++ showUserBuildTarget ut ++ " (" ++ showBuildTargetKind bt ++ ")" | (ut, bt) <- amb ] | (target, amb) <- targets ] where showBuildTargetKind (BuildTargetComponent _ ) = "component" showBuildTargetKind (BuildTargetModule _ _) = "module" showBuildTargetKind (BuildTargetFile _ _) = "file" ---------------------------------- -- Top level BuildTarget matcher -- matchBuildTarget :: PackageDescription -> UserBuildTarget -> Bool -> Match BuildTarget matchBuildTarget pkg = \utarget fexists -> case utarget of UserBuildTargetSingle str1 -> matchBuildTarget1 cinfo str1 fexists UserBuildTargetDouble str1 str2 -> matchBuildTarget2 cinfo str1 str2 fexists UserBuildTargetTriple str1 str2 str3 -> matchBuildTarget3 cinfo str1 str2 str3 fexists where cinfo = pkgComponentInfo pkg matchBuildTarget1 :: [ComponentInfo] -> String -> Bool -> Match BuildTarget matchBuildTarget1 cinfo str1 fexists = matchComponent1 cinfo str1 `matchPlusShadowing` matchModule1 cinfo str1 `matchPlusShadowing` matchFile1 cinfo str1 fexists matchBuildTarget2 :: [ComponentInfo] -> String -> String -> Bool -> Match BuildTarget matchBuildTarget2 cinfo str1 str2 fexists = matchComponent2 cinfo str1 str2 `matchPlusShadowing` matchModule2 cinfo str1 str2 `matchPlusShadowing` matchFile2 cinfo str1 str2 fexists matchBuildTarget3 :: [ComponentInfo] -> String -> String -> String -> Bool -> Match BuildTarget matchBuildTarget3 cinfo str1 str2 str3 fexists = matchModule3 cinfo str1 str2 str3 `matchPlusShadowing` matchFile3 cinfo str1 str2 str3 fexists data ComponentInfo = ComponentInfo { cinfoName :: ComponentName, cinfoStrName :: ComponentStringName, cinfoSrcDirs :: [FilePath], cinfoModules :: [ModuleName], cinfoHsFiles :: [FilePath], -- other hs files (like main.hs) cinfoCFiles :: [FilePath], cinfoJsFiles :: [FilePath] } type ComponentStringName = String pkgComponentInfo :: PackageDescription -> [ComponentInfo] pkgComponentInfo pkg = [ ComponentInfo { cinfoName = componentName c, cinfoStrName = componentStringName pkg (componentName c), cinfoSrcDirs = hsSourceDirs bi, cinfoModules = componentModules c, cinfoHsFiles = componentHsFiles c, cinfoCFiles = cSources bi, cinfoJsFiles = jsSources bi } | c <- pkgComponents pkg , let bi = componentBuildInfo c ] componentStringName :: Package pkg => pkg -> ComponentName -> ComponentStringName componentStringName pkg CLibName = display (packageName pkg) componentStringName _ (CExeName name) = name componentStringName _ (CTestName name) = name componentStringName _ (CBenchName name) = name componentModules :: Component -> [ModuleName] componentModules (CLib lib) = libModules lib componentModules (CExe exe) = exeModules exe componentModules (CTest test) = testModules test componentModules (CBench bench) = benchmarkModules bench componentHsFiles :: Component -> [FilePath] componentHsFiles (CExe exe) = [modulePath exe] componentHsFiles (CTest TestSuite { testInterface = TestSuiteExeV10 _ mainfile }) = [mainfile] componentHsFiles (CBench Benchmark { benchmarkInterface = BenchmarkExeV10 _ mainfile }) = [mainfile] componentHsFiles _ = [] {- ex_cs :: [ComponentInfo] ex_cs = [ (mkC (CExeName "foo") ["src1", "src1/src2"] ["Foo", "Src2.Bar", "Bar"]) , (mkC (CExeName "tst") ["src1", "test"] ["Foo"]) ] where mkC n ds ms = ComponentInfo n (componentStringName pkgid n) ds (map mkMn ms) mkMn :: String -> ModuleName mkMn = fromJust . simpleParse pkgid :: PackageIdentifier Just pkgid = simpleParse "thelib" -} ------------------------------ -- Matching component kinds -- data ComponentKind = LibKind | ExeKind | TestKind | BenchKind deriving (Eq, Ord, Show) componentKind :: ComponentName -> ComponentKind componentKind CLibName = LibKind componentKind (CExeName _) = ExeKind componentKind (CTestName _) = TestKind componentKind (CBenchName _) = BenchKind cinfoKind :: ComponentInfo -> ComponentKind cinfoKind = componentKind . cinfoName matchComponentKind :: String -> Match ComponentKind matchComponentKind s | s `elem` ["lib", "library"] = increaseConfidence >> return LibKind | s `elem` ["exe", "executable"] = increaseConfidence >> return ExeKind | s `elem` ["tst", "test", "test-suite"] = increaseConfidence >> return TestKind | s `elem` ["bench", "benchmark"] = increaseConfidence >> return BenchKind | otherwise = matchErrorExpected "component kind" s showComponentKind :: ComponentKind -> String showComponentKind LibKind = "library" showComponentKind ExeKind = "executable" showComponentKind TestKind = "test-suite" showComponentKind BenchKind = "benchmark" showComponentKindShort :: ComponentKind -> String showComponentKindShort LibKind = "lib" showComponentKindShort ExeKind = "exe" showComponentKindShort TestKind = "test" showComponentKindShort BenchKind = "bench" ------------------------------ -- Matching component targets -- matchComponent1 :: [ComponentInfo] -> String -> Match BuildTarget matchComponent1 cs = \str1 -> do guardComponentName str1 c <- matchComponentName cs str1 return (BuildTargetComponent (cinfoName c)) matchComponent2 :: [ComponentInfo] -> String -> String -> Match BuildTarget matchComponent2 cs = \str1 str2 -> do ckind <- matchComponentKind str1 guardComponentName str2 c <- matchComponentKindAndName cs ckind str2 return (BuildTargetComponent (cinfoName c)) -- utils: guardComponentName :: String -> Match () guardComponentName s | all validComponentChar s && not (null s) = increaseConfidence | otherwise = matchErrorExpected "component name" s where validComponentChar c = isAlphaNum c || c == '.' || c == '_' || c == '-' || c == '\'' matchComponentName :: [ComponentInfo] -> String -> Match ComponentInfo matchComponentName cs str = orNoSuchThing "component" str $ increaseConfidenceFor $ matchInexactly caseFold [ (cinfoStrName c, c) | c <- cs ] str matchComponentKindAndName :: [ComponentInfo] -> ComponentKind -> String -> Match ComponentInfo matchComponentKindAndName cs ckind str = orNoSuchThing (showComponentKind ckind ++ " component") str $ increaseConfidenceFor $ matchInexactly (\(ck, cn) -> (ck, caseFold cn)) [ ((cinfoKind c, cinfoStrName c), c) | c <- cs ] (ckind, str) ------------------------------ -- Matching module targets -- matchModule1 :: [ComponentInfo] -> String -> Match BuildTarget matchModule1 cs = \str1 -> do guardModuleName str1 nubMatchErrors $ do c <- tryEach cs let ms = cinfoModules c m <- matchModuleName ms str1 return (BuildTargetModule (cinfoName c) m) matchModule2 :: [ComponentInfo] -> String -> String -> Match BuildTarget matchModule2 cs = \str1 str2 -> do guardComponentName str1 guardModuleName str2 c <- matchComponentName cs str1 let ms = cinfoModules c m <- matchModuleName ms str2 return (BuildTargetModule (cinfoName c) m) matchModule3 :: [ComponentInfo] -> String -> String -> String -> Match BuildTarget matchModule3 cs str1 str2 str3 = do ckind <- matchComponentKind str1 guardComponentName str2 c <- matchComponentKindAndName cs ckind str2 guardModuleName str3 let ms = cinfoModules c m <- matchModuleName ms str3 return (BuildTargetModule (cinfoName c) m) -- utils: guardModuleName :: String -> Match () guardModuleName s | all validModuleChar s && not (null s) = increaseConfidence | otherwise = matchErrorExpected "module name" s where validModuleChar c = isAlphaNum c || c == '.' || c == '_' || c == '\'' matchModuleName :: [ModuleName] -> String -> Match ModuleName matchModuleName ms str = orNoSuchThing "module" str $ increaseConfidenceFor $ matchInexactly caseFold [ (display m, m) | m <- ms ] str ------------------------------ -- Matching file targets -- matchFile1 :: [ComponentInfo] -> String -> Bool -> Match BuildTarget matchFile1 cs str1 exists = nubMatchErrors $ do c <- tryEach cs filepath <- matchComponentFile c str1 exists return (BuildTargetFile (cinfoName c) filepath) matchFile2 :: [ComponentInfo] -> String -> String -> Bool -> Match BuildTarget matchFile2 cs str1 str2 exists = do guardComponentName str1 c <- matchComponentName cs str1 filepath <- matchComponentFile c str2 exists return (BuildTargetFile (cinfoName c) filepath) matchFile3 :: [ComponentInfo] -> String -> String -> String -> Bool -> Match BuildTarget matchFile3 cs str1 str2 str3 exists = do ckind <- matchComponentKind str1 guardComponentName str2 c <- matchComponentKindAndName cs ckind str2 filepath <- matchComponentFile c str3 exists return (BuildTargetFile (cinfoName c) filepath) matchComponentFile :: ComponentInfo -> String -> Bool -> Match FilePath matchComponentFile c str fexists = expecting "file" str $ matchPlus (matchFileExists str fexists) (matchPlusShadowing (msum [ matchModuleFileRooted dirs ms str , matchOtherFileRooted dirs hsFiles str ]) (msum [ matchModuleFileUnrooted ms str , matchOtherFileUnrooted hsFiles str , matchOtherFileUnrooted cFiles str , matchOtherFileUnrooted jsFiles str ])) where dirs = cinfoSrcDirs c ms = cinfoModules c hsFiles = cinfoHsFiles c cFiles = cinfoCFiles c jsFiles = cinfoJsFiles c -- utils matchFileExists :: FilePath -> Bool -> Match a matchFileExists _ False = mzero matchFileExists fname True = do increaseConfidence matchErrorNoSuch "file" fname matchModuleFileUnrooted :: [ModuleName] -> String -> Match FilePath matchModuleFileUnrooted ms str = do let filepath = normalise str _ <- matchModuleFileStem ms filepath return filepath matchModuleFileRooted :: [FilePath] -> [ModuleName] -> String -> Match FilePath matchModuleFileRooted dirs ms str = nubMatches $ do let filepath = normalise str filepath' <- matchDirectoryPrefix dirs filepath _ <- matchModuleFileStem ms filepath' return filepath matchModuleFileStem :: [ModuleName] -> FilePath -> Match ModuleName matchModuleFileStem ms = increaseConfidenceFor . matchInexactly caseFold [ (toFilePath m, m) | m <- ms ] . dropExtension matchOtherFileRooted :: [FilePath] -> [FilePath] -> FilePath -> Match FilePath matchOtherFileRooted dirs fs str = do let filepath = normalise str filepath' <- matchDirectoryPrefix dirs filepath _ <- matchFile fs filepath' return filepath matchOtherFileUnrooted :: [FilePath] -> FilePath -> Match FilePath matchOtherFileUnrooted fs str = do let filepath = normalise str _ <- matchFile fs filepath return filepath matchFile :: [FilePath] -> FilePath -> Match FilePath matchFile fs = increaseConfidenceFor . matchInexactly caseFold [ (f, f) | f <- fs ] matchDirectoryPrefix :: [FilePath] -> FilePath -> Match FilePath matchDirectoryPrefix dirs filepath = exactMatches $ catMaybes [ stripDirectory (normalise dir) filepath | dir <- dirs ] where stripDirectory :: FilePath -> FilePath -> Maybe FilePath stripDirectory dir fp = joinPath `fmap` stripPrefix (splitDirectories dir) (splitDirectories fp) ------------------------------ -- Matching monad -- -- | A matcher embodies a way to match some input as being some recognised -- value. In particular it deals with multiple and ambigious matches. -- -- There are various matcher primitives ('matchExactly', 'matchInexactly'), -- ways to combine matchers ('ambigiousWith', 'shadows') and finally we can -- run a matcher against an input using 'findMatch'. -- data Match a = NoMatch Confidence [MatchError] | ExactMatch Confidence [a] | InexactMatch Confidence [a] deriving Show type Confidence = Int data MatchError = MatchErrorExpected String String | MatchErrorNoSuch String String deriving (Show, Eq) instance Alternative Match where empty = mzero (<|>) = mplus instance MonadPlus Match where mzero = matchZero mplus = matchPlus matchZero :: Match a matchZero = NoMatch 0 [] -- | Combine two matchers. Exact matches are used over inexact matches -- but if we have multiple exact, or inexact then the we collect all the -- ambigious matches. -- matchPlus :: Match a -> Match a -> Match a matchPlus (ExactMatch d1 xs) (ExactMatch d2 xs') = ExactMatch (max d1 d2) (xs ++ xs') matchPlus a@(ExactMatch _ _ ) (InexactMatch _ _ ) = a matchPlus a@(ExactMatch _ _ ) (NoMatch _ _ ) = a matchPlus (InexactMatch _ _ ) b@(ExactMatch _ _ ) = b matchPlus (InexactMatch d1 xs) (InexactMatch d2 xs') = InexactMatch (max d1 d2) (xs ++ xs') matchPlus a@(InexactMatch _ _ ) (NoMatch _ _ ) = a matchPlus (NoMatch _ _ ) b@(ExactMatch _ _ ) = b matchPlus (NoMatch _ _ ) b@(InexactMatch _ _ ) = b matchPlus a@(NoMatch d1 ms) b@(NoMatch d2 ms') | d1 > d2 = a | d1 < d2 = b | otherwise = NoMatch d1 (ms ++ ms') -- | Combine two matchers. This is similar to 'ambigiousWith' with the -- difference that an exact match from the left matcher shadows any exact -- match on the right. Inexact matches are still collected however. -- matchPlusShadowing :: Match a -> Match a -> Match a matchPlusShadowing a@(ExactMatch _ _) (ExactMatch _ _) = a matchPlusShadowing a b = matchPlus a b instance Functor Match where fmap _ (NoMatch d ms) = NoMatch d ms fmap f (ExactMatch d xs) = ExactMatch d (fmap f xs) fmap f (InexactMatch d xs) = InexactMatch d (fmap f xs) instance Applicative Match where pure = return (<*>) = ap instance Monad Match where return a = ExactMatch 0 [a] NoMatch d ms >>= _ = NoMatch d ms ExactMatch d xs >>= f = addDepth d $ foldr matchPlus matchZero (map f xs) InexactMatch d xs >>= f = addDepth d . forceInexact $ foldr matchPlus matchZero (map f xs) addDepth :: Confidence -> Match a -> Match a addDepth d' (NoMatch d msgs) = NoMatch (d'+d) msgs addDepth d' (ExactMatch d xs) = ExactMatch (d'+d) xs addDepth d' (InexactMatch d xs) = InexactMatch (d'+d) xs forceInexact :: Match a -> Match a forceInexact (ExactMatch d ys) = InexactMatch d ys forceInexact m = m ------------------------------ -- Various match primitives -- matchErrorExpected, matchErrorNoSuch :: String -> String -> Match a matchErrorExpected thing got = NoMatch 0 [MatchErrorExpected thing got] matchErrorNoSuch thing got = NoMatch 0 [MatchErrorNoSuch thing got] expecting :: String -> String -> Match a -> Match a expecting thing got (NoMatch 0 _) = matchErrorExpected thing got expecting _ _ m = m orNoSuchThing :: String -> String -> Match a -> Match a orNoSuchThing thing got (NoMatch 0 _) = matchErrorNoSuch thing got orNoSuchThing _ _ m = m increaseConfidence :: Match () increaseConfidence = ExactMatch 1 [()] increaseConfidenceFor :: Match a -> Match a increaseConfidenceFor m = m >>= \r -> increaseConfidence >> return r nubMatches :: Eq a => Match a -> Match a nubMatches (NoMatch d msgs) = NoMatch d msgs nubMatches (ExactMatch d xs) = ExactMatch d (nub xs) nubMatches (InexactMatch d xs) = InexactMatch d (nub xs) nubMatchErrors :: Match a -> Match a nubMatchErrors (NoMatch d msgs) = NoMatch d (nub msgs) nubMatchErrors (ExactMatch d xs) = ExactMatch d xs nubMatchErrors (InexactMatch d xs) = InexactMatch d xs -- | Lift a list of matches to an exact match. -- exactMatches, inexactMatches :: [a] -> Match a exactMatches [] = matchZero exactMatches xs = ExactMatch 0 xs inexactMatches [] = matchZero inexactMatches xs = InexactMatch 0 xs tryEach :: [a] -> Match a tryEach = exactMatches ------------------------------ -- Top level match runner -- -- | Given a matcher and a key to look up, use the matcher to find all the -- possible matches. There may be 'None', a single 'Unambiguous' match or -- you may have an 'Ambiguous' match with several possibilities. -- findMatch :: Eq b => Match b -> MaybeAmbigious b findMatch match = case match of NoMatch _ msgs -> None (nub msgs) ExactMatch _ xs -> checkAmbigious xs InexactMatch _ xs -> checkAmbigious xs where checkAmbigious xs = case nub xs of [x] -> Unambiguous x xs' -> Ambiguous xs' data MaybeAmbigious a = None [MatchError] | Unambiguous a | Ambiguous [a] deriving Show ------------------------------ -- Basic matchers -- {- -- | A primitive matcher that looks up a value in a finite 'Map'. The -- value must match exactly. -- matchExactly :: forall a b. Ord a => [(a, b)] -> (a -> Match b) matchExactly xs = \x -> case Map.lookup x m of Nothing -> matchZero Just ys -> ExactMatch 0 ys where m :: Ord a => Map a [b] m = Map.fromListWith (++) [ (k,[x]) | (k,x) <- xs ] -} -- | A primitive matcher that looks up a value in a finite 'Map'. It checks -- for an exact or inexact match. We get an inexact match if the match -- is not exact, but the canonical forms match. It takes a canonicalisation -- function for this purpose. -- -- So for example if we used string case fold as the canonicalisation -- function, then we would get case insensitive matching (but it will still -- report an exact match when the case matches too). -- matchInexactly :: (Ord a, Ord a') => (a -> a') -> [(a, b)] -> (a -> Match b) matchInexactly cannonicalise xs = \x -> case Map.lookup x m of Just ys -> exactMatches ys Nothing -> case Map.lookup (cannonicalise x) m' of Just ys -> inexactMatches ys Nothing -> matchZero where m = Map.fromListWith (++) [ (k,[x]) | (k,x) <- xs ] -- the map of canonicalised keys to groups of inexact matches m' = Map.mapKeysWith (++) cannonicalise m ------------------------------ -- Utils -- caseFold :: String -> String caseFold = lowercase Cabal-1.22.5.0/Distribution/Simple/CCompiler.hs0000644000000000000000000001156412627136220017260 0ustar0000000000000000{-# LANGUAGE CPP #-} ----------------------------------------------------------------------------- -- | -- Module : Distribution.Simple.CCompiler -- Copyright : 2011, Dan Knapp -- -- Maintainer : cabal-devel@haskell.org -- Portability : portable -- -- This simple package provides types and functions for interacting with -- C compilers. Currently it's just a type enumerating extant C-like -- languages, which we call dialects. {- 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 Isaac Jones 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. -} module Distribution.Simple.CCompiler ( CDialect(..), cSourceExtensions, cDialectFilenameExtension, filenameCDialect ) where #if __GLASGOW_HASKELL__ < 710 import Data.Monoid ( Monoid(..) ) #endif import System.FilePath ( takeExtension ) -- | Represents a dialect of C. The Monoid instance expresses backward -- compatibility, in the sense that 'mappend a b' is the least inclusive -- dialect which both 'a' and 'b' can be correctly interpreted as. data CDialect = C | ObjectiveC | CPlusPlus | ObjectiveCPlusPlus deriving (Eq, Show) instance Monoid CDialect where mempty = C mappend C anything = anything mappend ObjectiveC CPlusPlus = ObjectiveCPlusPlus mappend CPlusPlus ObjectiveC = ObjectiveCPlusPlus mappend _ ObjectiveCPlusPlus = ObjectiveCPlusPlus mappend ObjectiveC _ = ObjectiveC mappend CPlusPlus _ = CPlusPlus mappend ObjectiveCPlusPlus _ = ObjectiveCPlusPlus -- | A list of all file extensions which are recognized as possibly containing -- some dialect of C code. Note that this list is only for source files, -- not for header files. cSourceExtensions :: [String] cSourceExtensions = ["c", "i", "ii", "m", "mi", "mm", "M", "mii", "cc", "cp", "cxx", "cpp", "CPP", "c++", "C"] -- | Takes a dialect of C and whether code is intended to be passed through -- the preprocessor, and returns a filename extension for containing that -- code. cDialectFilenameExtension :: CDialect -> Bool -> String cDialectFilenameExtension C True = "c" cDialectFilenameExtension C False = "i" cDialectFilenameExtension ObjectiveC True = "m" cDialectFilenameExtension ObjectiveC False = "mi" cDialectFilenameExtension CPlusPlus True = "cpp" cDialectFilenameExtension CPlusPlus False = "ii" cDialectFilenameExtension ObjectiveCPlusPlus True = "mm" cDialectFilenameExtension ObjectiveCPlusPlus False = "mii" -- | Infers from a filename's extension the dialect of C which it contains, -- and whether it is intended to be passed through the preprocessor. filenameCDialect :: String -> Maybe (CDialect, Bool) filenameCDialect filename = do extension <- case takeExtension filename of '.':ext -> Just ext _ -> Nothing case extension of "c" -> return (C, True) "i" -> return (C, False) "ii" -> return (CPlusPlus, False) "m" -> return (ObjectiveC, True) "mi" -> return (ObjectiveC, False) "mm" -> return (ObjectiveCPlusPlus, True) "M" -> return (ObjectiveCPlusPlus, True) "mii" -> return (ObjectiveCPlusPlus, False) "cc" -> return (CPlusPlus, True) "cp" -> return (CPlusPlus, True) "cxx" -> return (CPlusPlus, True) "cpp" -> return (CPlusPlus, True) "CPP" -> return (CPlusPlus, True) "c++" -> return (CPlusPlus, True) "C" -> return (CPlusPlus, True) _ -> Nothing Cabal-1.22.5.0/Distribution/Simple/Command.hs0000644000000000000000000005760412627136220016766 0ustar0000000000000000{-# LANGUAGE CPP #-} ----------------------------------------------------------------------------- -- | -- Module : Distribution.Simple.Command -- Copyright : Duncan Coutts 2007 -- License : BSD3 -- -- Maintainer : cabal-devel@haskell.org -- Portability : portable -- -- This is to do with command line handling. The Cabal command line is -- organised into a number of named sub-commands (much like darcs). The -- 'CommandUI' abstraction represents one of these sub-commands, with a name, -- description, a set of flags. Commands can be associated with actions and -- run. It handles some common stuff automatically, like the @--help@ and -- command line completion flags. It is designed to allow other tools make -- derived commands. This feature is used heavily in @cabal-install@. module Distribution.Simple.Command ( -- * Command interface CommandUI(..), commandShowOptions, CommandParse(..), commandParseArgs, getNormalCommandDescriptions, helpCommandUI, -- ** Constructing commands ShowOrParseArgs(..), usageDefault, usageAlternatives, mkCommandUI, hiddenCommand, -- ** Associating actions with commands Command, commandAddAction, noExtraFlags, -- ** Running commands commandsRun, -- * Option Fields OptionField(..), Name, -- ** Constructing Option Fields option, multiOption, -- ** Liftings & Projections liftOption, viewAsFieldDescr, -- * Option Descriptions OptDescr(..), Description, SFlags, LFlags, OptFlags, ArgPlaceHolder, -- ** OptDescr 'smart' constructors MkOptDescr, reqArg, reqArg', optArg, optArg', noArg, boolOpt, boolOpt', choiceOpt, choiceOptFromEnum ) where import Control.Monad import Data.Char (isAlpha, toLower) import Data.List (sortBy) import Data.Maybe #if __GLASGOW_HASKELL__ < 710 import Data.Monoid #endif import qualified Distribution.GetOpt as GetOpt import Distribution.Text ( Text(disp, parse) ) import Distribution.ParseUtils import Distribution.ReadE import Distribution.Simple.Utils (die, intercalate) import Text.PrettyPrint ( punctuate, cat, comma, text ) import Text.PrettyPrint as PP ( empty ) data CommandUI flags = CommandUI { -- | The name of the command as it would be entered on the command line. -- For example @\"build\"@. commandName :: String, -- | A short, one line description of the command to use in help texts. commandSynopsis :: String, -- | A function that maps a program name to a usage summary for this -- command. commandUsage :: String -> String, -- | Additional explanation of the command to use in help texts. commandDescription :: Maybe (String -> String), -- | Post-Usage notes and examples in help texts commandNotes :: Maybe (String -> String), -- | Initial \/ empty flags commandDefaultFlags :: flags, -- | All the Option fields for this command commandOptions :: ShowOrParseArgs -> [OptionField flags] } data ShowOrParseArgs = ShowArgs | ParseArgs type Name = String type Description = String -- | We usually have a data type for storing configuration values, where -- every field stores a configuration option, and the user sets -- the value either via command line flags or a configuration file. -- An individual OptionField models such a field, and we usually -- build a list of options associated to a configuration data type. data OptionField a = OptionField { optionName :: Name, optionDescr :: [OptDescr a] } -- | An OptionField takes one or more OptDescrs, describing the command line -- interface for the field. data OptDescr a = ReqArg Description OptFlags ArgPlaceHolder (ReadE (a->a)) (a -> [String]) | OptArg Description OptFlags ArgPlaceHolder (ReadE (a->a)) (a->a) (a -> [Maybe String]) | ChoiceOpt [(Description, OptFlags, a->a, a -> Bool)] | BoolOpt Description OptFlags{-True-} OptFlags{-False-} (Bool -> a -> a) (a-> Maybe Bool) -- | Short command line option strings type SFlags = [Char] -- | Long command line option strings type LFlags = [String] type OptFlags = (SFlags,LFlags) type ArgPlaceHolder = String -- | Create an option taking a single OptDescr. -- No explicit Name is given for the Option, the name is the first LFlag given. option :: SFlags -> LFlags -> Description -> get -> set -> MkOptDescr get set a -> OptionField a option sf lf@(n:_) d get set arg = OptionField n [arg sf lf d get set] option _ _ _ _ _ _ = error $ "Distribution.command.option: " ++ "An OptionField must have at least one LFlag" -- | Create an option taking several OptDescrs. -- You will have to give the flags and description individually to the -- OptDescr constructor. multiOption :: Name -> get -> set -> [get -> set -> OptDescr a] -- ^MkOptDescr constructors partially -- applied to flags and description. -> OptionField a multiOption n get set args = OptionField n [arg get set | arg <- args] type MkOptDescr get set a = SFlags -> LFlags -> Description -> get -> set -> OptDescr a -- | Create a string-valued command line interface. reqArg :: Monoid b => ArgPlaceHolder -> ReadE b -> (b -> [String]) -> MkOptDescr (a -> b) (b -> a -> a) a reqArg ad mkflag showflag sf lf d get set = ReqArg d (sf,lf) ad (fmap (\a b -> set (get b `mappend` a) b) mkflag) (showflag . get) -- | Create a string-valued command line interface with a default value. optArg :: Monoid b => ArgPlaceHolder -> ReadE b -> b -> (b -> [Maybe String]) -> MkOptDescr (a -> b) (b -> a -> a) a optArg ad mkflag def showflag sf lf d get set = OptArg d (sf,lf) ad (fmap (\a b -> set (get b `mappend` a) b) mkflag) (\b -> set (get b `mappend` def) b) (showflag . get) -- | (String -> a) variant of "reqArg" reqArg' :: Monoid b => ArgPlaceHolder -> (String -> b) -> (b -> [String]) -> MkOptDescr (a -> b) (b -> a -> a) a reqArg' ad mkflag showflag = reqArg ad (succeedReadE mkflag) showflag -- | (String -> a) variant of "optArg" optArg' :: Monoid b => ArgPlaceHolder -> (Maybe String -> b) -> (b -> [Maybe String]) -> MkOptDescr (a -> b) (b -> a -> a) a optArg' ad mkflag showflag = optArg ad (succeedReadE (mkflag . Just)) def showflag where def = mkflag Nothing noArg :: (Eq b, Monoid b) => b -> MkOptDescr (a -> b) (b -> a -> a) a noArg flag sf lf d = choiceOpt [(flag, (sf,lf), d)] sf lf d boolOpt :: (b -> Maybe Bool) -> (Bool -> b) -> SFlags -> SFlags -> MkOptDescr (a -> b) (b -> a -> a) a boolOpt g s sfT sfF _sf _lf@(n:_) d get set = BoolOpt d (sfT, ["enable-"++n]) (sfF, ["disable-"++n]) (set.s) (g.get) boolOpt _ _ _ _ _ _ _ _ _ = error "Distribution.Simple.Setup.boolOpt: unreachable" boolOpt' :: (b -> Maybe Bool) -> (Bool -> b) -> OptFlags -> OptFlags -> MkOptDescr (a -> b) (b -> a -> a) a boolOpt' g s ffT ffF _sf _lf d get set = BoolOpt d ffT ffF (set.s) (g . get) -- | create a Choice option choiceOpt :: Eq b => [(b,OptFlags,Description)] -> MkOptDescr (a -> b) (b -> a -> a) a choiceOpt aa_ff _sf _lf _d get set = ChoiceOpt alts where alts = [(d,flags, set alt, (==alt) . get) | (alt,flags,d) <- aa_ff] -- | create a Choice option out of an enumeration type. -- As long flags, the Show output is used. As short flags, the first character -- which does not conflict with a previous one is used. choiceOptFromEnum :: (Bounded b, Enum b, Show b, Eq b) => MkOptDescr (a -> b) (b -> a -> a) a choiceOptFromEnum _sf _lf d get = choiceOpt [ (x, (sf, [map toLower $ show x]), d') | (x, sf) <- sflags' , let d' = d ++ show x] _sf _lf d get where sflags' = foldl f [] [firstOne..] f prev x = let prevflags = concatMap snd prev in prev ++ take 1 [(x, [toLower sf]) | sf <- show x, isAlpha sf , toLower sf `notElem` prevflags] firstOne = minBound `asTypeOf` get undefined commandGetOpts :: ShowOrParseArgs -> CommandUI flags -> [GetOpt.OptDescr (flags -> flags)] commandGetOpts showOrParse command = concatMap viewAsGetOpt (commandOptions command showOrParse) viewAsGetOpt :: OptionField a -> [GetOpt.OptDescr (a->a)] viewAsGetOpt (OptionField _n aa) = concatMap optDescrToGetOpt aa where optDescrToGetOpt (ReqArg d (cs,ss) arg_desc set _) = [GetOpt.Option cs ss (GetOpt.ReqArg set' arg_desc) d] where set' = readEOrFail set optDescrToGetOpt (OptArg d (cs,ss) arg_desc set def _) = [GetOpt.Option cs ss (GetOpt.OptArg set' arg_desc) d] where set' Nothing = def set' (Just txt) = readEOrFail set txt optDescrToGetOpt (ChoiceOpt alts) = [GetOpt.Option sf lf (GetOpt.NoArg set) d | (d,(sf,lf),set,_) <- alts ] optDescrToGetOpt (BoolOpt d (sfT, lfT) ([], []) set _) = [ GetOpt.Option sfT lfT (GetOpt.NoArg (set True)) d ] optDescrToGetOpt (BoolOpt d ([], []) (sfF, lfF) set _) = [ GetOpt.Option sfF lfF (GetOpt.NoArg (set False)) d ] optDescrToGetOpt (BoolOpt d (sfT,lfT) (sfF, lfF) set _) = [ GetOpt.Option sfT lfT (GetOpt.NoArg (set True)) ("Enable " ++ d) , GetOpt.Option sfF lfF (GetOpt.NoArg (set False)) ("Disable " ++ d) ] -- | to view as a FieldDescr, we sort the list of interfaces (Req > Bool > -- Choice > Opt) and consider only the first one. viewAsFieldDescr :: OptionField a -> FieldDescr a viewAsFieldDescr (OptionField _n []) = error "Distribution.command.viewAsFieldDescr: unexpected" viewAsFieldDescr (OptionField n dd) = FieldDescr n get set where optDescr = head $ sortBy cmp dd cmp :: OptDescr a -> OptDescr a -> Ordering ReqArg{} `cmp` ReqArg{} = EQ ReqArg{} `cmp` _ = GT BoolOpt{} `cmp` ReqArg{} = LT BoolOpt{} `cmp` BoolOpt{} = EQ BoolOpt{} `cmp` _ = GT ChoiceOpt{} `cmp` ReqArg{} = LT ChoiceOpt{} `cmp` BoolOpt{} = LT ChoiceOpt{} `cmp` ChoiceOpt{} = EQ ChoiceOpt{} `cmp` _ = GT OptArg{} `cmp` OptArg{} = EQ OptArg{} `cmp` _ = LT -- get :: a -> Doc get t = case optDescr of ReqArg _ _ _ _ ppr -> (cat . punctuate comma . map text . ppr) t OptArg _ _ _ _ _ ppr -> case ppr t of [] -> PP.empty (Nothing : _) -> text "True" (Just a : _) -> text a ChoiceOpt alts -> fromMaybe PP.empty $ listToMaybe [ text lf | (_,(_,lf:_), _,enabled) <- alts, enabled t] BoolOpt _ _ _ _ enabled -> (maybe PP.empty disp . enabled) t -- set :: LineNo -> String -> a -> ParseResult a set line val a = case optDescr of ReqArg _ _ _ readE _ -> ($ a) `liftM` runE line n readE val -- We parse for a single value instead of a -- list, as one can't really implement -- parseList :: ReadE a -> ReadE [a] with -- the current ReadE definition ChoiceOpt{} -> case getChoiceByLongFlag optDescr val of Just f -> return (f a) _ -> syntaxError line val BoolOpt _ _ _ setV _ -> (`setV` a) `liftM` runP line n parse val OptArg _ _ _ readE _ _ -> ($ a) `liftM` runE line n readE val -- Optional arguments are parsed just like -- required arguments here; we don't -- provide a method to set an OptArg field -- to the default value. getChoiceByLongFlag :: OptDescr b -> String -> Maybe (b->b) getChoiceByLongFlag (ChoiceOpt alts) val = listToMaybe [ set | (_,(_sf,lf:_), set, _) <- alts , lf == val] getChoiceByLongFlag _ _ = error "Distribution.command.getChoiceByLongFlag: expected a choice option" getCurrentChoice :: OptDescr a -> a -> [String] getCurrentChoice (ChoiceOpt alts) a = [ lf | (_,(_sf,lf:_), _, currentChoice) <- alts, currentChoice a] getCurrentChoice _ _ = error "Command.getChoice: expected a Choice OptDescr" liftOption :: (b -> a) -> (a -> (b -> b)) -> OptionField a -> OptionField b liftOption get' set' opt = opt { optionDescr = liftOptDescr get' set' `map` optionDescr opt} liftOptDescr :: (b -> a) -> (a -> (b -> b)) -> OptDescr a -> OptDescr b liftOptDescr get' set' (ChoiceOpt opts) = ChoiceOpt [ (d, ff, liftSet get' set' set , (get . get')) | (d, ff, set, get) <- opts] liftOptDescr get' set' (OptArg d ff ad set def get) = OptArg d ff ad (liftSet get' set' `fmap` set) (liftSet get' set' def) (get . get') liftOptDescr get' set' (ReqArg d ff ad set get) = ReqArg d ff ad (liftSet get' set' `fmap` set) (get . get') liftOptDescr get' set' (BoolOpt d ffT ffF set get) = BoolOpt d ffT ffF (liftSet get' set' . set) (get . get') liftSet :: (b -> a) -> (a -> (b -> b)) -> (a -> a) -> b -> b liftSet get' set' set x = set' (set $ get' x) x -- | Show flags in the standard long option command line format commandShowOptions :: CommandUI flags -> flags -> [String] commandShowOptions command v = concat [ showOptDescr v od | o <- commandOptions command ParseArgs , od <- optionDescr o] where maybePrefix [] = [] maybePrefix (lOpt:_) = ["--" ++ lOpt] showOptDescr :: a -> OptDescr a -> [String] showOptDescr x (BoolOpt _ (_,lfTs) (_,lfFs) _ enabled) = case enabled x of Nothing -> [] Just True -> maybePrefix lfTs Just False -> maybePrefix lfFs showOptDescr x c@ChoiceOpt{} = ["--" ++ val | val <- getCurrentChoice c x] showOptDescr x (ReqArg _ (_ssff,lf:_) _ _ showflag) = [ "--"++lf++"="++flag | flag <- showflag x ] showOptDescr x (OptArg _ (_ssff,lf:_) _ _ _ showflag) = [ case flag of Just s -> "--"++lf++"="++s Nothing -> "--"++lf | flag <- showflag x ] showOptDescr _ _ = error "Distribution.Simple.Command.showOptDescr: unreachable" commandListOptions :: CommandUI flags -> [String] commandListOptions command = concatMap listOption $ addCommonFlags ShowArgs $ -- This is a slight hack, we don't want -- "--list-options" showing up in the -- list options output, so use ShowArgs commandGetOpts ShowArgs command where listOption (GetOpt.Option shortNames longNames _ _) = [ "-" ++ [name] | name <- shortNames ] ++ [ "--" ++ name | name <- longNames ] -- | The help text for this command with descriptions of all the options. commandHelp :: CommandUI flags -> String -> String commandHelp command pname = commandSynopsis command ++ "\n\n" ++ commandUsage command pname ++ ( case commandDescription command of Nothing -> "" Just desc -> '\n': desc pname) ++ "\n" ++ ( if cname == "" then "Global flags:" else "Flags for " ++ cname ++ ":" ) ++ ( GetOpt.usageInfo "" . addCommonFlags ShowArgs $ commandGetOpts ShowArgs command ) ++ ( case commandNotes command of Nothing -> "" Just notes -> '\n': notes pname) where cname = commandName command -- | Default "usage" documentation text for commands. usageDefault :: String -> String -> String usageDefault name pname = "Usage: " ++ pname ++ " " ++ name ++ " [FLAGS]\n\n" ++ "Flags for " ++ name ++ ":" -- | Create "usage" documentation from a list of parameter -- configurations. usageAlternatives :: String -> [String] -> String -> String usageAlternatives name strs pname = unlines [ start ++ pname ++ " " ++ name ++ " " ++ s | let starts = "Usage: " : repeat " or: " , (start, s) <- zip starts strs ] -- | Make a Command from standard 'GetOpt' options. mkCommandUI :: String -- ^ name -> String -- ^ synopsis -> [String] -- ^ usage alternatives -> flags -- ^ initial\/empty flags -> (ShowOrParseArgs -> [OptionField flags]) -- ^ options -> CommandUI flags mkCommandUI name synopsis usages flags options = CommandUI { commandName = name , commandSynopsis = synopsis , commandDescription = Nothing , commandNotes = Nothing , commandUsage = usageAlternatives name usages , commandDefaultFlags = flags , commandOptions = options } -- | Common flags that apply to every command data CommonFlag = HelpFlag | ListOptionsFlag commonFlags :: ShowOrParseArgs -> [GetOpt.OptDescr CommonFlag] commonFlags showOrParseArgs = case showOrParseArgs of ShowArgs -> [help] ParseArgs -> [help, list] where help = GetOpt.Option helpShortFlags ["help"] (GetOpt.NoArg HelpFlag) "Show this help text" helpShortFlags = case showOrParseArgs of ShowArgs -> ['h'] ParseArgs -> ['h', '?'] list = GetOpt.Option [] ["list-options"] (GetOpt.NoArg ListOptionsFlag) "Print a list of command line flags" addCommonFlags :: ShowOrParseArgs -> [GetOpt.OptDescr a] -> [GetOpt.OptDescr (Either CommonFlag a)] addCommonFlags showOrParseArgs options = map (fmapOptDesc Left) (commonFlags showOrParseArgs) ++ map (fmapOptDesc Right) options where fmapOptDesc f (GetOpt.Option s l d m) = GetOpt.Option s l (fmapArgDesc f d) m fmapArgDesc f (GetOpt.NoArg a) = GetOpt.NoArg (f a) fmapArgDesc f (GetOpt.ReqArg s d) = GetOpt.ReqArg (f . s) d fmapArgDesc f (GetOpt.OptArg s d) = GetOpt.OptArg (f . s) d -- | Parse a bunch of command line arguments -- commandParseArgs :: CommandUI flags -> Bool -- ^ Is the command a global or subcommand? -> [String] -> CommandParse (flags -> flags, [String]) commandParseArgs command global args = let options = addCommonFlags ParseArgs $ commandGetOpts ParseArgs command order | global = GetOpt.RequireOrder | otherwise = GetOpt.Permute in case GetOpt.getOpt' order options args of (flags, _, _, _) | any listFlag flags -> CommandList (commandListOptions command) | any helpFlag flags -> CommandHelp (commandHelp command) where listFlag (Left ListOptionsFlag) = True; listFlag _ = False helpFlag (Left HelpFlag) = True; helpFlag _ = False (flags, opts, opts', []) | global || null opts' -> CommandReadyToGo (accum flags, mix opts opts') | otherwise -> CommandErrors (unrecognised opts') (_, _, _, errs) -> CommandErrors errs where -- Note: It is crucial to use reverse function composition here or to -- reverse the flags here as we want to process the flags left to right -- but data flow in function composition is right to left. accum flags = foldr (flip (.)) id [ f | Right f <- flags ] unrecognised opts = [ "unrecognized " ++ "'" ++ (commandName command) ++ "'" ++ " option `" ++ opt ++ "'\n" | opt <- opts ] -- For unrecognised global flags we put them in the position just after -- the command, if there is one. This gives us a chance to parse them -- as sub-command rather than global flags. mix [] ys = ys mix (x:xs) ys = x:ys++xs data CommandParse flags = CommandHelp (String -> String) | CommandList [String] | CommandErrors [String] | CommandReadyToGo flags instance Functor CommandParse where fmap _ (CommandHelp help) = CommandHelp help fmap _ (CommandList opts) = CommandList opts fmap _ (CommandErrors errs) = CommandErrors errs fmap f (CommandReadyToGo flags) = CommandReadyToGo (f flags) data CommandType = NormalCommand | HiddenCommand data Command action = Command String String ([String] -> CommandParse action) CommandType -- | Mark command as hidden. Hidden commands don't show up in the 'progname -- help' or 'progname --help' output. hiddenCommand :: Command action -> Command action hiddenCommand (Command name synopsys f _cmdType) = Command name synopsys f HiddenCommand commandAddAction :: CommandUI flags -> (flags -> [String] -> action) -> Command action commandAddAction command action = Command (commandName command) (commandSynopsis command) (fmap (uncurry applyDefaultArgs) . commandParseArgs command False) NormalCommand where applyDefaultArgs mkflags args = let flags = mkflags (commandDefaultFlags command) in action flags args commandsRun :: CommandUI a -> [Command action] -> [String] -> CommandParse (a, CommandParse action) commandsRun globalCommand commands args = case commandParseArgs globalCommand True args of CommandHelp help -> CommandHelp help CommandList opts -> CommandList (opts ++ commandNames) CommandErrors errs -> CommandErrors errs CommandReadyToGo (mkflags, args') -> case args' of ("help":cmdArgs) -> handleHelpCommand cmdArgs (name:cmdArgs) -> case lookupCommand name of [Command _ _ action _] -> CommandReadyToGo (flags, action cmdArgs) _ -> CommandReadyToGo (flags, badCommand name) [] -> CommandReadyToGo (flags, noCommand) where flags = mkflags (commandDefaultFlags globalCommand) where lookupCommand cname = [ cmd | cmd@(Command cname' _ _ _) <- commands' , cname' == cname ] noCommand = CommandErrors ["no command given (try --help)\n"] badCommand cname = CommandErrors ["unrecognised command: " ++ cname ++ " (try --help)\n"] commands' = commands ++ [commandAddAction helpCommandUI undefined] commandNames = [ name | (Command name _ _ NormalCommand) <- commands' ] -- A bit of a hack: support "prog help" as a synonym of "prog --help" -- furthermore, support "prog help command" as "prog command --help" handleHelpCommand cmdArgs = case commandParseArgs helpCommandUI True cmdArgs of CommandHelp help -> CommandHelp help CommandList list -> CommandList (list ++ commandNames) CommandErrors _ -> CommandHelp globalHelp CommandReadyToGo (_,[]) -> CommandHelp globalHelp CommandReadyToGo (_,(name:cmdArgs')) -> case lookupCommand name of [Command _ _ action _] -> case action ("--help":cmdArgs') of CommandHelp help -> CommandHelp help CommandList _ -> CommandList [] _ -> CommandHelp globalHelp _ -> badCommand name where globalHelp = commandHelp globalCommand -- | Utility function, many commands do not accept additional flags. This -- action fails with a helpful error message if the user supplies any extra. -- noExtraFlags :: [String] -> IO () noExtraFlags [] = return () noExtraFlags extraFlags = die $ "Unrecognised flags: " ++ intercalate ", " extraFlags --TODO: eliminate this function and turn it into a variant on commandAddAction -- instead like commandAddActionNoArgs that doesn't supply the [String] -- | Helper function for creating globalCommand description getNormalCommandDescriptions :: [Command action] -> [(String, String)] getNormalCommandDescriptions cmds = [ (name, description) | Command name description _ NormalCommand <- cmds ] helpCommandUI :: CommandUI () helpCommandUI = mkCommandUI "help" "Help about commands." ["[FLAGS]", "COMMAND [FLAGS]"] () (const []) Cabal-1.22.5.0/Distribution/Simple/Compiler.hs0000644000000000000000000002504212627136220017151 0ustar0000000000000000{-# LANGUAGE DeriveGeneric #-} ----------------------------------------------------------------------------- -- | -- Module : Distribution.Simple.Compiler -- Copyright : Isaac Jones 2003-2004 -- License : BSD3 -- -- Maintainer : cabal-devel@haskell.org -- Portability : portable -- -- This should be a much more sophisticated abstraction than it is. Currently -- it's just a bit of data about the compiler, like it's flavour and name and -- version. The reason it's just data is because currently it has to be in -- 'Read' and 'Show' so it can be saved along with the 'LocalBuildInfo'. The -- only interesting bit of info it contains is a mapping between language -- extensions and compiler command line flags. This module also defines a -- 'PackageDB' type which is used to refer to package databases. Most compilers -- only know about a single global package collection but GHC has a global and -- per-user one and it lets you create arbitrary other package databases. We do -- not yet fully support this latter feature. module Distribution.Simple.Compiler ( -- * Haskell implementations module Distribution.Compiler, Compiler(..), showCompilerId, showCompilerIdWithAbi, compilerFlavor, compilerVersion, compilerCompatVersion, compilerInfo, -- * Support for package databases PackageDB(..), PackageDBStack, registrationPackageDB, absolutePackageDBPaths, absolutePackageDBPath, -- * Support for optimisation levels OptimisationLevel(..), flagToOptimisationLevel, -- * Support for debug info levels DebugInfoLevel(..), flagToDebugInfoLevel, -- * Support for language extensions Flag, languageToFlags, unsupportedLanguages, extensionsToFlags, unsupportedExtensions, parmakeSupported, reexportedModulesSupported, renamingPackageFlagsSupported, packageKeySupported ) where import Distribution.Compiler import Distribution.Version (Version(..)) import Distribution.Text (display) import Language.Haskell.Extension (Language(Haskell98), Extension) import Control.Monad (liftM) import Distribution.Compat.Binary (Binary) import Data.List (nub) import qualified Data.Map as M (Map, lookup) import Data.Maybe (catMaybes, isNothing, listToMaybe) import GHC.Generics (Generic) import System.Directory (canonicalizePath) data Compiler = Compiler { compilerId :: CompilerId, -- ^ Compiler flavour and version. compilerAbiTag :: AbiTag, -- ^ Tag for distinguishing incompatible ABI's on the same architecture/os. compilerCompat :: [CompilerId], -- ^ Other implementations that this compiler claims to be compatible with. compilerLanguages :: [(Language, Flag)], -- ^ Supported language standards. compilerExtensions :: [(Extension, Flag)], -- ^ Supported extensions. compilerProperties :: M.Map String String -- ^ A key-value map for properties not covered by the above fields. } deriving (Generic, Show, Read) instance Binary Compiler showCompilerId :: Compiler -> String showCompilerId = display . compilerId showCompilerIdWithAbi :: Compiler -> String showCompilerIdWithAbi comp = display (compilerId comp) ++ case compilerAbiTag comp of NoAbiTag -> [] AbiTag xs -> '-':xs compilerFlavor :: Compiler -> CompilerFlavor compilerFlavor = (\(CompilerId f _) -> f) . compilerId compilerVersion :: Compiler -> Version compilerVersion = (\(CompilerId _ v) -> v) . compilerId compilerCompatVersion :: CompilerFlavor -> Compiler -> Maybe Version compilerCompatVersion flavor comp | compilerFlavor comp == flavor = Just (compilerVersion comp) | otherwise = listToMaybe [ v | CompilerId fl v <- compilerCompat comp, fl == flavor ] compilerInfo :: Compiler -> CompilerInfo compilerInfo c = CompilerInfo (compilerId c) (compilerAbiTag c) (Just . compilerCompat $ c) (Just . map fst . compilerLanguages $ c) (Just . map fst . compilerExtensions $ c) -- ------------------------------------------------------------ -- * Package databases -- ------------------------------------------------------------ -- |Some compilers have a notion of a database of available packages. -- For some there is just one global db of packages, other compilers -- support a per-user or an arbitrary db specified at some location in -- the file system. This can be used to build isloated environments of -- packages, for example to build a collection of related packages -- without installing them globally. -- data PackageDB = GlobalPackageDB | UserPackageDB | SpecificPackageDB FilePath deriving (Eq, Generic, Ord, Show, Read) instance Binary PackageDB -- | We typically get packages from several databases, and stack them -- together. This type lets us be explicit about that stacking. For example -- typical stacks include: -- -- > [GlobalPackageDB] -- > [GlobalPackageDB, UserPackageDB] -- > [GlobalPackageDB, SpecificPackageDB "package.conf.inplace"] -- -- Note that the 'GlobalPackageDB' is invariably at the bottom since it -- contains the rts, base and other special compiler-specific packages. -- -- We are not restricted to using just the above combinations. In particular -- we can use several custom package dbs and the user package db together. -- -- When it comes to writing, the top most (last) package is used. -- type PackageDBStack = [PackageDB] -- | Return the package that we should register into. This is the package db at -- the top of the stack. -- registrationPackageDB :: PackageDBStack -> PackageDB registrationPackageDB [] = error "internal error: empty package db set" registrationPackageDB dbs = last dbs -- | Make package paths absolute absolutePackageDBPaths :: PackageDBStack -> IO PackageDBStack absolutePackageDBPaths = mapM absolutePackageDBPath absolutePackageDBPath :: PackageDB -> IO PackageDB absolutePackageDBPath GlobalPackageDB = return GlobalPackageDB absolutePackageDBPath UserPackageDB = return UserPackageDB absolutePackageDBPath (SpecificPackageDB db) = SpecificPackageDB `liftM` canonicalizePath db -- ------------------------------------------------------------ -- * Optimisation levels -- ------------------------------------------------------------ -- | Some compilers support optimising. Some have different levels. -- For compilers that do not the level is just capped to the level -- they do support. -- data OptimisationLevel = NoOptimisation | NormalOptimisation | MaximumOptimisation deriving (Bounded, Enum, Eq, Generic, Read, Show) instance Binary OptimisationLevel flagToOptimisationLevel :: Maybe String -> OptimisationLevel flagToOptimisationLevel Nothing = NormalOptimisation flagToOptimisationLevel (Just s) = case reads s of [(i, "")] | i >= fromEnum (minBound :: OptimisationLevel) && i <= fromEnum (maxBound :: OptimisationLevel) -> toEnum i | otherwise -> error $ "Bad optimisation level: " ++ show i ++ ". Valid values are 0..2" _ -> error $ "Can't parse optimisation level " ++ s -- ------------------------------------------------------------ -- * Debug info levels -- ------------------------------------------------------------ -- | Some compilers support emitting debug info. Some have different -- levels. For compilers that do not the level is just capped to the -- level they do support. -- data DebugInfoLevel = NoDebugInfo | MinimalDebugInfo | NormalDebugInfo | MaximalDebugInfo deriving (Bounded, Enum, Eq, Generic, Read, Show) instance Binary DebugInfoLevel flagToDebugInfoLevel :: Maybe String -> DebugInfoLevel flagToDebugInfoLevel Nothing = NormalDebugInfo flagToDebugInfoLevel (Just s) = case reads s of [(i, "")] | i >= fromEnum (minBound :: DebugInfoLevel) && i <= fromEnum (maxBound :: DebugInfoLevel) -> toEnum i | otherwise -> error $ "Bad debug info level: " ++ show i ++ ". Valid values are 0..3" _ -> error $ "Can't parse debug info level " ++ s -- ------------------------------------------------------------ -- * Languages and Extensions -- ------------------------------------------------------------ unsupportedLanguages :: Compiler -> [Language] -> [Language] unsupportedLanguages comp langs = [ lang | lang <- langs , isNothing (languageToFlag comp lang) ] languageToFlags :: Compiler -> Maybe Language -> [Flag] languageToFlags comp = filter (not . null) . catMaybes . map (languageToFlag comp) . maybe [Haskell98] (\x->[x]) languageToFlag :: Compiler -> Language -> Maybe Flag languageToFlag comp ext = lookup ext (compilerLanguages comp) -- |For the given compiler, return the extensions it does not support. unsupportedExtensions :: Compiler -> [Extension] -> [Extension] unsupportedExtensions comp exts = [ ext | ext <- exts , isNothing (extensionToFlag comp ext) ] type Flag = String -- |For the given compiler, return the flags for the supported extensions. extensionsToFlags :: Compiler -> [Extension] -> [Flag] extensionsToFlags comp = nub . filter (not . null) . catMaybes . map (extensionToFlag comp) extensionToFlag :: Compiler -> Extension -> Maybe Flag extensionToFlag comp ext = lookup ext (compilerExtensions comp) -- | Does this compiler support parallel --make mode? parmakeSupported :: Compiler -> Bool parmakeSupported = ghcSupported "Support parallel --make" -- | Does this compiler support reexported-modules? reexportedModulesSupported :: Compiler -> Bool reexportedModulesSupported = ghcSupported "Support reexported-modules" -- | Does this compiler support thinning/renaming on package flags? renamingPackageFlagsSupported :: Compiler -> Bool renamingPackageFlagsSupported = ghcSupported "Support thinning and renaming package flags" -- | Does this compiler support package keys? packageKeySupported :: Compiler -> Bool packageKeySupported = ghcSupported "Uses package keys" -- | Utility function for GHC only features ghcSupported :: String -> Compiler -> Bool ghcSupported key comp = case compilerFlavor comp of GHC -> checkProp GHCJS -> checkProp _ -> False where checkProp = case M.lookup key (compilerProperties comp) of Just "YES" -> True _ -> False Cabal-1.22.5.0/Distribution/Simple/Configure.hs0000644000000000000000000023454212627136220017327 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} ----------------------------------------------------------------------------- -- | -- Module : Distribution.Simple.Configure -- Copyright : Isaac Jones 2003-2005 -- License : BSD3 -- -- Maintainer : cabal-devel@haskell.org -- Portability : portable -- -- This deals with the /configure/ phase. It provides the 'configure' action -- which is given the package description and configure flags. It then tries -- to: configure the compiler; resolves any conditionals in the package -- description; resolve the package dependencies; check if all the extensions -- used by this package are supported by the compiler; check that all the build -- tools are available (including version checks if appropriate); checks for -- any required @pkg-config@ packages (updating the 'BuildInfo' with the -- results) -- -- Then based on all this it saves the info in the 'LocalBuildInfo' and writes -- it out to the @dist\/setup-config@ file. It also displays various details to -- the user, the amount of information displayed depending on the verbosity -- level. module Distribution.Simple.Configure (configure, writePersistBuildConfig, getConfigStateFile, getPersistBuildConfig, checkPersistBuildConfigOutdated, tryGetPersistBuildConfig, maybeGetPersistBuildConfig, localBuildInfoFile, getInstalledPackages, getPackageDBContents, configCompiler, configCompilerAux, configCompilerEx, configCompilerAuxEx, ccLdOptionsBuildInfo, checkForeignDeps, interpretPackageDbFlags, ConfigStateFileError(..), tryGetConfigStateFile, platformDefines, ) where import Distribution.Compiler ( CompilerId(..) ) import Distribution.Utils.NubList import Distribution.Simple.Compiler ( CompilerFlavor(..), Compiler(..), compilerFlavor, compilerVersion , compilerInfo , showCompilerId, unsupportedLanguages, unsupportedExtensions , PackageDB(..), PackageDBStack, reexportedModulesSupported , packageKeySupported, renamingPackageFlagsSupported ) import Distribution.Simple.PreProcess ( platformDefines ) import Distribution.Package ( PackageName(PackageName), PackageIdentifier(..), PackageId , packageName, packageVersion, Package(..) , Dependency(Dependency), simplifyDependency , InstalledPackageId(..), thisPackageVersion , mkPackageKey, PackageKey(..), packageKeyLibraryName ) import qualified Distribution.InstalledPackageInfo as Installed import Distribution.InstalledPackageInfo (InstalledPackageInfo, emptyInstalledPackageInfo) import qualified Distribution.Simple.PackageIndex as PackageIndex import Distribution.Simple.PackageIndex (InstalledPackageIndex) import Distribution.PackageDescription as PD ( PackageDescription(..), specVersion, GenericPackageDescription(..) , Library(..), hasLibs, Executable(..), BuildInfo(..), allExtensions , HookedBuildInfo, updatePackageDescription, allBuildInfo , Flag(flagName), FlagName(..), TestSuite(..), Benchmark(..) , ModuleReexport(..) , defaultRenaming ) import Distribution.ModuleName ( ModuleName ) import Distribution.PackageDescription.Configuration ( finalizePackageDescription, mapTreeData ) import Distribution.PackageDescription.Check ( PackageCheck(..), checkPackage, checkPackageFiles ) import Distribution.Simple.Program ( Program(..), ProgramLocation(..), ConfiguredProgram(..) , ProgramConfiguration, defaultProgramConfiguration , ProgramSearchPathEntry(..), getProgramSearchPath, setProgramSearchPath , configureAllKnownPrograms, knownPrograms, lookupKnownProgram , userSpecifyArgss, userSpecifyPaths , lookupProgram, requireProgram, requireProgramVersion , pkgConfigProgram, gccProgram, rawSystemProgramStdoutConf ) import Distribution.Simple.Setup ( ConfigFlags(..), CopyDest(..), Flag(..), fromFlag, fromFlagOrDefault , flagToMaybe ) import Distribution.Simple.InstallDirs ( InstallDirs(..), defaultInstallDirs, combineInstallDirs ) import Distribution.Simple.LocalBuildInfo ( LocalBuildInfo(..), Component(..), ComponentLocalBuildInfo(..) , LibraryName(..) , absoluteInstallDirs, prefixRelativeInstallDirs, inplacePackageId , ComponentName(..), showComponentName, pkgEnabledComponents , componentBuildInfo, componentName, checkComponentsCyclic ) import Distribution.Simple.BuildPaths ( autogenModulesDir ) import Distribution.Simple.Utils ( die, warn, info, setupMessage , createDirectoryIfMissingVerbose, moreRecentFile , intercalate, cabalVersion , writeFileAtomic , withTempFile ) import Distribution.System ( OS(..), buildOS, Platform (..), buildPlatform ) import Distribution.Version ( Version(..), anyVersion, orLaterVersion, withinRange, isAnyVersion ) import Distribution.Verbosity ( Verbosity, lessVerbose ) import qualified Distribution.Simple.GHC as GHC import qualified Distribution.Simple.GHCJS as GHCJS import qualified Distribution.Simple.JHC as JHC import qualified Distribution.Simple.LHC as LHC import qualified Distribution.Simple.UHC as UHC import qualified Distribution.Simple.HaskellSuite as HaskellSuite -- Prefer the more generic Data.Traversable.mapM to Prelude.mapM import Prelude hiding ( mapM ) import Control.Exception ( ErrorCall(..), Exception, evaluate, throw, throwIO, try ) import Control.Monad ( liftM, when, unless, foldM, filterM ) import Distribution.Compat.Binary ( decodeOrFailIO, encode ) import Data.ByteString.Lazy (ByteString) import qualified Data.ByteString as BS import qualified Data.ByteString.Lazy.Char8 as BLC8 import Data.List ( (\\), nub, partition, isPrefixOf, inits, stripPrefix ) import Data.Maybe ( isNothing, catMaybes, fromMaybe, isJust ) import Data.Either ( partitionEithers ) import qualified Data.Set as Set #if __GLASGOW_HASKELL__ < 710 import Data.Monoid ( Monoid(..) ) #endif import qualified Data.Map as Map import Data.Map (Map) import Data.Traversable ( mapM ) import Data.Typeable import System.Directory ( doesFileExist, createDirectoryIfMissing, getTemporaryDirectory ) import System.FilePath ( (), isAbsolute ) import qualified System.Info ( compilerName, compilerVersion ) import System.IO ( hPutStrLn, hClose ) import Distribution.Text ( Text(disp), display, simpleParse ) import Text.PrettyPrint ( render, (<>), ($+$), char, text, comma , quotes, punctuate, nest, sep, hsep ) import Distribution.Compat.Exception ( catchExit, catchIO ) data ConfigStateFileError = ConfigStateFileNoHeader | ConfigStateFileBadHeader | ConfigStateFileNoParse | ConfigStateFileMissing | ConfigStateFileBadVersion PackageIdentifier PackageIdentifier (Either ConfigStateFileError LocalBuildInfo) deriving (Typeable) instance Show ConfigStateFileError where show ConfigStateFileNoHeader = "Saved package config file header is missing. " ++ "Try re-running the 'configure' command." show ConfigStateFileBadHeader = "Saved package config file header is corrupt. " ++ "Try re-running the 'configure' command." show ConfigStateFileNoParse = "Saved package config file body is corrupt. " ++ "Try re-running the 'configure' command." show ConfigStateFileMissing = "Run the 'configure' command first." show (ConfigStateFileBadVersion oldCabal oldCompiler _) = "You need to re-run the 'configure' command. " ++ "The version of Cabal being used has changed (was " ++ display oldCabal ++ ", now " ++ display currentCabalId ++ ")." ++ badCompiler where badCompiler | oldCompiler == currentCompilerId = "" | otherwise = " Additionally the compiler is different (was " ++ display oldCompiler ++ ", now " ++ display currentCompilerId ++ ") which is probably the cause of the problem." instance Exception ConfigStateFileError getConfigStateFile :: FilePath -> IO LocalBuildInfo getConfigStateFile filename = do exists <- doesFileExist filename unless exists $ throwIO ConfigStateFileMissing -- Read the config file into a strict ByteString to avoid problems with -- lazy I/O, then convert to lazy because the binary package needs that. contents <- BS.readFile filename let (header, body) = BLC8.span (/='\n') (BLC8.fromChunks [contents]) headerParseResult <- try $ evaluate $ parseHeader header let (cabalId, compId) = case headerParseResult of Left (ErrorCall _) -> throw ConfigStateFileBadHeader Right x -> x let getStoredValue = do result <- decodeOrFailIO (BLC8.tail body) case result of Left _ -> throw ConfigStateFileNoParse Right x -> return x deferErrorIfBadVersion act | cabalId /= currentCabalId = do eResult <- try act throw $ ConfigStateFileBadVersion cabalId compId eResult | otherwise = act deferErrorIfBadVersion getStoredValue tryGetConfigStateFile :: FilePath -> IO (Either ConfigStateFileError LocalBuildInfo) tryGetConfigStateFile = try . getConfigStateFile -- |Try to read the 'localBuildInfoFile'. tryGetPersistBuildConfig :: FilePath -> IO (Either ConfigStateFileError LocalBuildInfo) tryGetPersistBuildConfig = try . getPersistBuildConfig -- | Read the 'localBuildInfoFile'. Throw an exception if the file is -- missing, if the file cannot be read, or if the file was created by an older -- version of Cabal. getPersistBuildConfig :: FilePath -> IO LocalBuildInfo getPersistBuildConfig = getConfigStateFile . localBuildInfoFile -- |Try to read the 'localBuildInfoFile'. maybeGetPersistBuildConfig :: FilePath -> IO (Maybe LocalBuildInfo) maybeGetPersistBuildConfig = liftM (either (const Nothing) Just) . tryGetPersistBuildConfig -- |After running configure, output the 'LocalBuildInfo' to the -- 'localBuildInfoFile'. writePersistBuildConfig :: FilePath -> LocalBuildInfo -> IO () writePersistBuildConfig distPref lbi = do createDirectoryIfMissing False distPref writeFileAtomic (localBuildInfoFile distPref) $ BLC8.unlines [showHeader pkgId, encode lbi] where pkgId = packageId $ localPkgDescr lbi currentCabalId :: PackageIdentifier currentCabalId = PackageIdentifier (PackageName "Cabal") cabalVersion currentCompilerId :: PackageIdentifier currentCompilerId = PackageIdentifier (PackageName System.Info.compilerName) System.Info.compilerVersion parseHeader :: ByteString -> (PackageIdentifier, PackageIdentifier) parseHeader header = case BLC8.words header of ["Saved", "package", "config", "for", pkgId, "written", "by", cabalId, "using", compId] -> fromMaybe (throw ConfigStateFileBadHeader) $ do _ <- simpleParse (BLC8.unpack pkgId) :: Maybe PackageIdentifier cabalId' <- simpleParse (BLC8.unpack cabalId) compId' <- simpleParse (BLC8.unpack compId) return (cabalId', compId') _ -> throw ConfigStateFileNoHeader showHeader :: PackageIdentifier -> ByteString showHeader pkgId = BLC8.unwords [ "Saved", "package", "config", "for" , BLC8.pack $ display pkgId , "written", "by" , BLC8.pack $ display currentCabalId , "using" , BLC8.pack $ display currentCompilerId ] -- |Check that localBuildInfoFile is up-to-date with respect to the -- .cabal file. checkPersistBuildConfigOutdated :: FilePath -> FilePath -> IO Bool checkPersistBuildConfigOutdated distPref pkg_descr_file = do pkg_descr_file `moreRecentFile` (localBuildInfoFile distPref) -- |@dist\/setup-config@ localBuildInfoFile :: FilePath -> FilePath localBuildInfoFile distPref = distPref "setup-config" -- ----------------------------------------------------------------------------- -- * Configuration -- ----------------------------------------------------------------------------- -- |Perform the \"@.\/setup configure@\" action. -- Returns the @.setup-config@ file. configure :: (GenericPackageDescription, HookedBuildInfo) -> ConfigFlags -> IO LocalBuildInfo configure (pkg_descr0, pbi) cfg = do let distPref = fromFlag (configDistPref cfg) buildDir' = distPref "build" verbosity = fromFlag (configVerbosity cfg) setupMessage verbosity "Configuring" (packageId pkg_descr0) unless (configLibCoverage cfg == NoFlag) $ do let enable | fromFlag (configLibCoverage cfg) = "enable" | otherwise = "disable" warn verbosity ("The flag --" ++ enable ++ "-library-coverage is deprecated. " ++ "Please use --" ++ enable ++ "-coverage instead.") createDirectoryIfMissingVerbose (lessVerbose verbosity) True distPref let programsConfig = mkProgramsConfig cfg (configPrograms cfg) userInstall = fromFlag (configUserInstall cfg) packageDbs = interpretPackageDbFlags userInstall (configPackageDBs cfg) -- detect compiler (comp, compPlatform, programsConfig') <- configCompilerEx (flagToMaybe $ configHcFlavor cfg) (flagToMaybe $ configHcPath cfg) (flagToMaybe $ configHcPkg cfg) programsConfig (lessVerbose verbosity) let version = compilerVersion comp flavor = compilerFlavor comp -- Create a PackageIndex that makes *any libraries that might be* -- defined internally to this package look like installed packages, in -- case an executable should refer to any of them as dependencies. -- -- It must be *any libraries that might be* defined rather than the -- actual definitions, because these depend on conditionals in the .cabal -- file, and we haven't resolved them yet. finalizePackageDescription -- does the resolution of conditionals, and it takes internalPackageSet -- as part of its input. -- -- Currently a package can define no more than one library (which has -- the same name as the package) but we could extend this later. -- If we later allowed private internal libraries, then here we would -- need to pre-scan the conditional data to make a list of all private -- libraries that could possibly be defined by the .cabal file. let pid = packageId pkg_descr0 internalPackage = emptyInstalledPackageInfo { --TODO: should use a per-compiler method to map the source -- package ID into an installed package id we can use -- for the internal package set. The open-codes use of -- InstalledPackageId . display here is a hack. Installed.installedPackageId = InstalledPackageId $ display $ pid, Installed.sourcePackageId = pid } internalPackageSet = PackageIndex.fromList [internalPackage] installedPackageSet <- getInstalledPackages (lessVerbose verbosity) comp packageDbs programsConfig' (allConstraints, requiredDepsMap) <- either die return $ combinedConstraints (configConstraints cfg) (configDependencies cfg) installedPackageSet let exactConf = fromFlagOrDefault False (configExactConfiguration cfg) -- Constraint test function for the solver dependencySatisfiable d@(Dependency depName verRange) | exactConf = -- When we're given '--exact-configuration', we assume that all -- dependencies and flags are exactly specified on the command -- line. Thus we only consult the 'requiredDepsMap'. Note that -- we're not doing the version range check, so if there's some -- dependency that wasn't specified on the command line, -- 'finalizePackageDescription' will fail. -- -- TODO: mention '--exact-configuration' in the error message -- when this fails? (depName `Map.member` requiredDepsMap) || isInternalDep | otherwise = -- Normal operation: just look up dependency in the package -- index. not . null . PackageIndex.lookupDependency pkgs' $ d where pkgs' = PackageIndex.insert internalPackage installedPackageSet isInternalDep = pkgName pid == depName && pkgVersion pid `withinRange` verRange enableTest t = t { testEnabled = fromFlag (configTests cfg) } flaggedTests = map (\(n, t) -> (n, mapTreeData enableTest t)) (condTestSuites pkg_descr0) enableBenchmark bm = bm { benchmarkEnabled = fromFlag (configBenchmarks cfg) } flaggedBenchmarks = map (\(n, bm) -> (n, mapTreeData enableBenchmark bm)) (condBenchmarks pkg_descr0) pkg_descr0'' = pkg_descr0 { condTestSuites = flaggedTests , condBenchmarks = flaggedBenchmarks } (pkg_descr0', flags) <- case finalizePackageDescription (configConfigurationsFlags cfg) dependencySatisfiable compPlatform (compilerInfo comp) allConstraints pkg_descr0'' of Right r -> return r Left missing -> die $ "At least the following dependencies are missing:\n" ++ (render . nest 4 . sep . punctuate comma . map (disp . simplifyDependency) $ missing) -- Sanity check: if '--exact-configuration' was given, ensure that the -- complete flag assignment was specified on the command line. when exactConf $ do let cmdlineFlags = map fst (configConfigurationsFlags cfg) allFlags = map flagName . genPackageFlags $ pkg_descr0 diffFlags = allFlags \\ cmdlineFlags when (not . null $ diffFlags) $ die $ "'--exact-conf' was given, " ++ "but the following flags were not specified: " ++ intercalate ", " (map show diffFlags) -- add extra include/lib dirs as specified in cfg -- we do it here so that those get checked too let pkg_descr = addExtraIncludeLibDirs pkg_descr0' unless (renamingPackageFlagsSupported comp || and [ rn == defaultRenaming | bi <- allBuildInfo pkg_descr , rn <- Map.elems (targetBuildRenaming bi)]) $ die $ "Your compiler does not support thinning and renaming on " ++ "package flags. To use this feature you probably must use " ++ "GHC 7.9 or later." when (not (null flags)) $ info verbosity $ "Flags chosen: " ++ intercalate ", " [ name ++ "=" ++ display value | (FlagName name, value) <- flags ] when (maybe False (not.null.PD.reexportedModules) (PD.library pkg_descr) && not (reexportedModulesSupported comp)) $ do die $ "Your compiler does not support module re-exports. To use " ++ "this feature you probably must use GHC 7.9 or later." checkPackageProblems verbosity pkg_descr0 (updatePackageDescription pbi pkg_descr) -- Handle hole instantiation (holeDeps, hole_insts) <- configureInstantiateWith pkg_descr cfg installedPackageSet let selectDependencies :: [Dependency] -> ([FailedDependency], [ResolvedDependency]) selectDependencies = (\xs -> ([ x | Left x <- xs ], [ x | Right x <- xs ])) . map (selectDependency internalPackageSet installedPackageSet requiredDepsMap) (failedDeps, allPkgDeps) = selectDependencies (buildDepends pkg_descr) internalPkgDeps = [ pkgid | InternalDependency _ pkgid <- allPkgDeps ] externalPkgDeps = [ pkg | ExternalDependency _ pkg <- allPkgDeps ] when (not (null internalPkgDeps) && not (newPackageDepsBehaviour pkg_descr)) $ die $ "The field 'build-depends: " ++ intercalate ", " (map (display . packageName) internalPkgDeps) ++ "' refers to a library which is defined within the same " ++ "package. To use this feature the package must specify at " ++ "least 'cabal-version: >= 1.8'." reportFailedDependencies failedDeps reportSelectedDependencies verbosity allPkgDeps let installDeps = Map.elems . Map.fromList . map (\v -> (Installed.installedPackageId v, v)) $ externalPkgDeps ++ holeDeps packageDependsIndex <- case PackageIndex.dependencyClosure installedPackageSet (map Installed.installedPackageId installDeps) of Left packageDependsIndex -> return packageDependsIndex Right broken -> die $ "The following installed packages are broken because other" ++ " packages they depend on are missing. These broken " ++ "packages must be rebuilt before they can be used.\n" ++ unlines [ "package " ++ display (packageId pkg) ++ " is broken due to missing package " ++ intercalate ", " (map display deps) | (pkg, deps) <- broken ] let pseudoTopPkg = emptyInstalledPackageInfo { Installed.installedPackageId = InstalledPackageId (display (packageId pkg_descr)), Installed.sourcePackageId = packageId pkg_descr, Installed.depends = map Installed.installedPackageId installDeps } case PackageIndex.dependencyInconsistencies . PackageIndex.insert pseudoTopPkg $ packageDependsIndex of [] -> return () inconsistencies -> warn verbosity $ "This package indirectly depends on multiple versions of the same " ++ "package. This is highly likely to cause a compile failure.\n" ++ unlines [ "package " ++ display pkg ++ " requires " ++ display (PackageIdentifier name ver) | (name, uses) <- inconsistencies , (pkg, ver) <- uses ] -- Calculate the package key. We're going to store it in LocalBuildInfo -- canonically, but ComponentsLocalBuildInfo also needs to know about it -- XXX Do we need the internal deps? -- NB: does *not* include holeDeps! let pkg_key = mkPackageKey (packageKeySupported comp) (package pkg_descr) (map Installed.packageKey externalPkgDeps) (map (\(k,(p,m)) -> (k,(Installed.packageKey p,m))) hole_insts) -- internal component graph buildComponents <- case mkComponentsGraph pkg_descr internalPkgDeps of Left componentCycle -> reportComponentCycle componentCycle Right components -> case mkComponentsLocalBuildInfo packageDependsIndex pkg_descr internalPkgDeps externalPkgDeps holeDeps (Map.fromList hole_insts) pkg_key components of Left problems -> reportModuleReexportProblems problems Right components' -> return components' -- installation directories defaultDirs <- defaultInstallDirs flavor userInstall (hasLibs pkg_descr) let installDirs = combineInstallDirs fromFlagOrDefault defaultDirs (configInstallDirs cfg) -- check languages and extensions let langlist = nub $ catMaybes $ map defaultLanguage (allBuildInfo pkg_descr) let langs = unsupportedLanguages comp langlist when (not (null langs)) $ die $ "The package " ++ display (packageId pkg_descr0) ++ " requires the following languages which are not " ++ "supported by " ++ display (compilerId comp) ++ ": " ++ intercalate ", " (map display langs) let extlist = nub $ concatMap allExtensions (allBuildInfo pkg_descr) let exts = unsupportedExtensions comp extlist when (not (null exts)) $ die $ "The package " ++ display (packageId pkg_descr0) ++ " requires the following language extensions which are not " ++ "supported by " ++ display (compilerId comp) ++ ": " ++ intercalate ", " (map display exts) -- configured known/required programs & external build tools -- exclude build-tool deps on "internal" exes in the same package let requiredBuildTools = [ buildTool | let exeNames = map exeName (executables pkg_descr) , bi <- allBuildInfo pkg_descr , buildTool@(Dependency (PackageName toolName) reqVer) <- buildTools bi , let isInternal = toolName `elem` exeNames -- we assume all internal build-tools are -- versioned with the package: && packageVersion pkg_descr `withinRange` reqVer , not isInternal ] programsConfig'' <- configureAllKnownPrograms (lessVerbose verbosity) programsConfig' >>= configureRequiredPrograms verbosity requiredBuildTools (pkg_descr', programsConfig''') <- configurePkgconfigPackages verbosity pkg_descr programsConfig'' split_objs <- if not (fromFlag $ configSplitObjs cfg) then return False else case flavor of GHC | version >= Version [6,5] [] -> return True GHCJS -> return True _ -> do warn verbosity ("this compiler does not support " ++ "--enable-split-objs; ignoring") return False let ghciLibByDefault = case compilerId comp of CompilerId GHC _ -> -- If ghc is non-dynamic, then ghci needs object files, -- so we build one by default. -- -- Technically, archive files should be sufficient for ghci, -- but because of GHC bug #8942, it has never been safe to -- rely on them. By the time that bug was fixed, ghci had -- been changed to read shared libraries instead of archive -- files (see next code block). not (GHC.isDynamic comp) CompilerId GHCJS _ -> not (GHCJS.isDynamic comp) _ -> False let sharedLibsByDefault | fromFlag (configDynExe cfg) = -- build a shared library if dynamically-linked -- executables are requested True | otherwise = case compilerId comp of CompilerId GHC _ -> -- if ghc is dynamic, then ghci needs a shared -- library, so we build one by default. GHC.isDynamic comp CompilerId GHCJS _ -> GHCJS.isDynamic comp _ -> False withSharedLib_ = -- build shared libraries if required by GHC or by the -- executable linking mode, but allow the user to force -- building only static library archives with -- --disable-shared. fromFlagOrDefault sharedLibsByDefault $ configSharedLib cfg withDynExe_ = fromFlag $ configDynExe cfg when (withDynExe_ && not withSharedLib_) $ warn verbosity $ "Executables will use dynamic linking, but a shared library " ++ "is not being built. Linking will fail if any executables " ++ "depend on the library." let withProfExe_ = fromFlagOrDefault False $ configProfExe cfg withProfLib_ = fromFlagOrDefault withProfExe_ $ configProfLib cfg when (withProfExe_ && not withProfLib_) $ warn verbosity $ "Executables will be built with profiling, but library " ++ "profiling is disabled. Linking will fail if any executables " ++ "depend on the library." let configCoverage_ = mappend (configCoverage cfg) (configLibCoverage cfg) cfg' = cfg { configCoverage = configCoverage_ } reloc <- if not (fromFlag $ configRelocatable cfg) then return False else return True let lbi = LocalBuildInfo { configFlags = cfg', extraConfigArgs = [], -- Currently configure does not -- take extra args, but if it -- did they would go here. installDirTemplates = installDirs, compiler = comp, hostPlatform = compPlatform, buildDir = buildDir', componentsConfigs = buildComponents, installedPkgs = packageDependsIndex, pkgDescrFile = Nothing, localPkgDescr = pkg_descr', pkgKey = pkg_key, instantiatedWith = hole_insts, withPrograms = programsConfig''', withVanillaLib = fromFlag $ configVanillaLib cfg, withProfLib = withProfLib_, withSharedLib = withSharedLib_, withDynExe = withDynExe_, withProfExe = withProfExe_, withOptimization = fromFlag $ configOptimization cfg, withDebugInfo = fromFlag $ configDebugInfo cfg, withGHCiLib = fromFlagOrDefault ghciLibByDefault $ configGHCiLib cfg, splitObjs = split_objs, stripExes = fromFlag $ configStripExes cfg, stripLibs = fromFlag $ configStripLibs cfg, withPackageDB = packageDbs, progPrefix = fromFlag $ configProgPrefix cfg, progSuffix = fromFlag $ configProgSuffix cfg, relocatable = reloc } when reloc (checkRelocatable verbosity pkg_descr lbi) let dirs = absoluteInstallDirs pkg_descr lbi NoCopyDest relative = prefixRelativeInstallDirs (packageId pkg_descr) lbi unless (isAbsolute (prefix dirs)) $ die $ "expected an absolute directory name for --prefix: " ++ prefix dirs info verbosity $ "Using " ++ display currentCabalId ++ " compiled by " ++ display currentCompilerId info verbosity $ "Using compiler: " ++ showCompilerId comp info verbosity $ "Using install prefix: " ++ prefix dirs let dirinfo name dir isPrefixRelative = info verbosity $ name ++ " installed in: " ++ dir ++ relNote where relNote = case buildOS of Windows | not (hasLibs pkg_descr) && isNothing isPrefixRelative -> " (fixed location)" _ -> "" dirinfo "Binaries" (bindir dirs) (bindir relative) dirinfo "Libraries" (libdir dirs) (libdir relative) dirinfo "Private binaries" (libexecdir dirs) (libexecdir relative) dirinfo "Data files" (datadir dirs) (datadir relative) dirinfo "Documentation" (docdir dirs) (docdir relative) dirinfo "Configuration files" (sysconfdir dirs) (sysconfdir relative) sequence_ [ reportProgram verbosity prog configuredProg | (prog, configuredProg) <- knownPrograms programsConfig''' ] return lbi where addExtraIncludeLibDirs pkg_descr = let extraBi = mempty { extraLibDirs = configExtraLibDirs cfg , PD.includeDirs = configExtraIncludeDirs cfg} modifyLib l = l{ libBuildInfo = libBuildInfo l `mappend` extraBi } modifyExecutable e = e{ buildInfo = buildInfo e `mappend` extraBi} in pkg_descr{ library = modifyLib `fmap` library pkg_descr , executables = modifyExecutable `map` executables pkg_descr} mkProgramsConfig :: ConfigFlags -> ProgramConfiguration -> ProgramConfiguration mkProgramsConfig cfg initialProgramsConfig = programsConfig where programsConfig = userSpecifyArgss (configProgramArgs cfg) . userSpecifyPaths (configProgramPaths cfg) . setProgramSearchPath searchpath $ initialProgramsConfig searchpath = getProgramSearchPath (initialProgramsConfig) ++ map ProgramSearchPathDir (fromNubList $ configProgramPathExtra cfg) -- ----------------------------------------------------------------------------- -- Configuring package dependencies reportProgram :: Verbosity -> Program -> Maybe ConfiguredProgram -> IO () reportProgram verbosity prog Nothing = info verbosity $ "No " ++ programName prog ++ " found" reportProgram verbosity prog (Just configuredProg) = info verbosity $ "Using " ++ programName prog ++ version ++ location where location = case programLocation configuredProg of FoundOnSystem p -> " found on system at: " ++ p UserSpecified p -> " given by user at: " ++ p version = case programVersion configuredProg of Nothing -> "" Just v -> " version " ++ display v hackageUrl :: String hackageUrl = "http://hackage.haskell.org/package/" data ResolvedDependency = ExternalDependency Dependency InstalledPackageInfo | InternalDependency Dependency PackageId -- should be a -- lib name data FailedDependency = DependencyNotExists PackageName | DependencyNoVersion Dependency -- | Test for a package dependency and record the version we have installed. selectDependency :: InstalledPackageIndex -- ^ Internally defined packages -> InstalledPackageIndex -- ^ Installed packages -> Map PackageName InstalledPackageInfo -- ^ Packages for which we have been given specific deps to use -> Dependency -> Either FailedDependency ResolvedDependency selectDependency internalIndex installedIndex requiredDepsMap dep@(Dependency pkgname vr) = -- If the dependency specification matches anything in the internal package -- index, then we prefer that match to anything in the second. -- For example: -- -- Name: MyLibrary -- Version: 0.1 -- Library -- .. -- Executable my-exec -- build-depends: MyLibrary -- -- We want "build-depends: MyLibrary" always to match the internal library -- even if there is a newer installed library "MyLibrary-0.2". -- However, "build-depends: MyLibrary >= 0.2" should match the installed one. case PackageIndex.lookupPackageName internalIndex pkgname of [(_,[pkg])] | packageVersion pkg `withinRange` vr -> Right $ InternalDependency dep (packageId pkg) _ -> case Map.lookup pkgname requiredDepsMap of -- If we know the exact pkg to use, then use it. Just pkginstance -> Right (ExternalDependency dep pkginstance) -- Otherwise we just pick an arbitrary instance of the latest version. Nothing -> case PackageIndex.lookupDependency installedIndex dep of [] -> Left $ DependencyNotExists pkgname pkgs -> Right $ ExternalDependency dep $ case last pkgs of (_ver, pkginstances) -> head pkginstances reportSelectedDependencies :: Verbosity -> [ResolvedDependency] -> IO () reportSelectedDependencies verbosity deps = info verbosity $ unlines [ "Dependency " ++ display (simplifyDependency dep) ++ ": using " ++ display pkgid | resolved <- deps , let (dep, pkgid) = case resolved of ExternalDependency dep' pkg' -> (dep', packageId pkg') InternalDependency dep' pkgid' -> (dep', pkgid') ] reportFailedDependencies :: [FailedDependency] -> IO () reportFailedDependencies [] = return () reportFailedDependencies failed = die (intercalate "\n\n" (map reportFailedDependency failed)) where reportFailedDependency (DependencyNotExists pkgname) = "there is no version of " ++ display pkgname ++ " installed.\n" ++ "Perhaps you need to download and install it from\n" ++ hackageUrl ++ display pkgname ++ "?" reportFailedDependency (DependencyNoVersion dep) = "cannot satisfy dependency " ++ display (simplifyDependency dep) ++ "\n" getInstalledPackages :: Verbosity -> Compiler -> PackageDBStack -> ProgramConfiguration -> IO InstalledPackageIndex getInstalledPackages verbosity comp packageDBs progconf = do when (null packageDBs) $ die $ "No package databases have been specified. If you use " ++ "--package-db=clear, you must follow it with --package-db= " ++ "with 'global', 'user' or a specific file." info verbosity "Reading installed packages..." case compilerFlavor comp of GHC -> GHC.getInstalledPackages verbosity packageDBs progconf GHCJS -> GHCJS.getInstalledPackages verbosity packageDBs progconf JHC -> JHC.getInstalledPackages verbosity packageDBs progconf LHC -> LHC.getInstalledPackages verbosity packageDBs progconf UHC -> UHC.getInstalledPackages verbosity comp packageDBs progconf HaskellSuite {} -> HaskellSuite.getInstalledPackages verbosity packageDBs progconf flv -> die $ "don't know how to find the installed packages for " ++ display flv -- | Like 'getInstalledPackages', but for a single package DB. getPackageDBContents :: Verbosity -> Compiler -> PackageDB -> ProgramConfiguration -> IO InstalledPackageIndex getPackageDBContents verbosity comp packageDB progconf = do info verbosity "Reading installed packages..." case compilerFlavor comp of GHC -> GHC.getPackageDBContents verbosity packageDB progconf GHCJS -> GHCJS.getPackageDBContents verbosity packageDB progconf -- For other compilers, try to fall back on 'getInstalledPackages'. _ -> getInstalledPackages verbosity comp [packageDB] progconf -- | The user interface specifies the package dbs to use with a combination of -- @--global@, @--user@ and @--package-db=global|user|clear|$file@. -- This function combines the global/user flag and interprets the package-db -- flag into a single package db stack. -- interpretPackageDbFlags :: Bool -> [Maybe PackageDB] -> PackageDBStack interpretPackageDbFlags userInstall specificDBs = extra initialStack specificDBs where initialStack | userInstall = [GlobalPackageDB, UserPackageDB] | otherwise = [GlobalPackageDB] extra dbs' [] = dbs' extra _ (Nothing:dbs) = extra [] dbs extra dbs' (Just db:dbs) = extra (dbs' ++ [db]) dbs newPackageDepsBehaviourMinVersion :: Version newPackageDepsBehaviourMinVersion = Version [1,7,1] [] -- In older cabal versions, there was only one set of package dependencies for -- the whole package. In this version, we can have separate dependencies per -- target, but we only enable this behaviour if the minimum cabal version -- specified is >= a certain minimum. Otherwise, for compatibility we use the -- old behaviour. newPackageDepsBehaviour :: PackageDescription -> Bool newPackageDepsBehaviour pkg = specVersion pkg >= newPackageDepsBehaviourMinVersion -- We are given both --constraint="foo < 2.0" style constraints and also -- specific packages to pick via --dependency="foo=foo-2.0-177d5cdf20962d0581". -- -- When finalising the package we have to take into account the specific -- installed deps we've been given, and the finalise function expects -- constraints, so we have to translate these deps into version constraints. -- -- But after finalising we then have to make sure we pick the right specific -- deps in the end. So we still need to remember which installed packages to -- pick. combinedConstraints :: [Dependency] -> [(PackageName, InstalledPackageId)] -> InstalledPackageIndex -> Either String ([Dependency], Map PackageName InstalledPackageInfo) combinedConstraints constraints dependencies installedPackages = do when (not (null badInstalledPackageIds)) $ Left $ render $ text "The following package dependencies were requested" $+$ nest 4 (dispDependencies badInstalledPackageIds) $+$ text "however the given installed package instance does not exist." when (not (null badNames)) $ Left $ render $ text "The following package dependencies were requested" $+$ nest 4 (dispDependencies badNames) $+$ text "however the installed package's name does not match the name given." --TODO: we don't check that all dependencies are used! return (allConstraints, idConstraintMap) where allConstraints :: [Dependency] allConstraints = constraints ++ [ thisPackageVersion (packageId pkg) | (_, _, Just pkg) <- dependenciesPkgInfo ] idConstraintMap :: Map PackageName InstalledPackageInfo idConstraintMap = Map.fromList [ (packageName pkg, pkg) | (_, _, Just pkg) <- dependenciesPkgInfo ] -- The dependencies along with the installed package info, if it exists dependenciesPkgInfo :: [(PackageName, InstalledPackageId, Maybe InstalledPackageInfo)] dependenciesPkgInfo = [ (pkgname, ipkgid, mpkg) | (pkgname, ipkgid) <- dependencies , let mpkg = PackageIndex.lookupInstalledPackageId installedPackages ipkgid ] -- If we looked up a package specified by an installed package id -- (i.e. someone has written a hash) and didn't find it then it's -- an error. badInstalledPackageIds = [ (pkgname, ipkgid) | (pkgname, ipkgid, Nothing) <- dependenciesPkgInfo ] -- If someone has written e.g. -- --dependency="foo=MyOtherLib-1.0-07...5bf30" then they have -- probably made a mistake. badNames = [ (requestedPkgName, ipkgid) | (requestedPkgName, ipkgid, Just pkg) <- dependenciesPkgInfo , let foundPkgName = packageName pkg , requestedPkgName /= foundPkgName ] dispDependencies deps = hsep [ text "--dependency=" <> quotes (disp pkgname <> char '=' <> disp ipkgid) | (pkgname, ipkgid) <- deps ] -- ----------------------------------------------------------------------------- -- Configuring hole instantiation configureInstantiateWith :: PackageDescription -> ConfigFlags -> InstalledPackageIndex -- ^ installed packages -> IO ([InstalledPackageInfo], [(ModuleName, (InstalledPackageInfo, ModuleName))]) configureInstantiateWith pkg_descr cfg installedPackageSet = do -- Holes: First, check and make sure the provided instantiation covers -- all the holes we know about. Indefinite package installation is -- not handled at all at this point. -- NB: We union together /all/ of the requirements when calculating -- the package key. -- NB: For now, we assume that dependencies don't contribute signatures. -- This will be handled by cabal-install; as far as ./Setup is -- concerned, the most important thing is to be provided correctly -- built dependencies. let signatures = maybe [] (\lib -> requiredSignatures lib ++ exposedSignatures lib) (PD.library pkg_descr) signatureSet = Set.fromList signatures instantiateMap = Map.fromList (configInstantiateWith cfg) missing_impls = filter (not . flip Map.member instantiateMap) signatures hole_insts0 = filter (\(k,_) -> Set.member k signatureSet) (configInstantiateWith cfg) when (not (null missing_impls)) $ die $ "Missing signature implementations for these modules: " ++ intercalate ", " (map display missing_impls) -- Holes: Next, we need to make sure we have packages to actually -- provide the implementations we're talking about. This is on top -- of the normal dependency resolution process. -- TODO: internal dependencies (e.g. the test package depending on the -- main library) is not currently supported let selectHoleDependency (k,(i,m)) = case PackageIndex.lookupInstalledPackageId installedPackageSet i of Just pkginst -> Right (k,(pkginst, m)) Nothing -> Left i (failed_hmap, hole_insts) = partitionEithers (map selectHoleDependency hole_insts0) holeDeps = map (fst.snd) hole_insts -- could have dups -- Holes: Finally, any dependencies selected this way have to be -- included in the allPkgs index, as well as the buildComponents. -- But don't report these as potential inconsistencies! when (not (null failed_hmap)) $ die $ "Could not resolve these package IDs (from signature implementations): " ++ intercalate ", " (map display failed_hmap) return (holeDeps, hole_insts) -- ----------------------------------------------------------------------------- -- Configuring program dependencies configureRequiredPrograms :: Verbosity -> [Dependency] -> ProgramConfiguration -> IO ProgramConfiguration configureRequiredPrograms verbosity deps conf = foldM (configureRequiredProgram verbosity) conf deps configureRequiredProgram :: Verbosity -> ProgramConfiguration -> Dependency -> IO ProgramConfiguration configureRequiredProgram verbosity conf (Dependency (PackageName progName) verRange) = case lookupKnownProgram progName conf of Nothing -> die ("Unknown build tool " ++ progName) Just prog -- requireProgramVersion always requires the program have a version -- but if the user says "build-depends: foo" ie no version constraint -- then we should not fail if we cannot discover the program version. | verRange == anyVersion -> do (_, conf') <- requireProgram verbosity prog conf return conf' | otherwise -> do (_, _, conf') <- requireProgramVersion verbosity prog verRange conf return conf' -- ----------------------------------------------------------------------------- -- Configuring pkg-config package dependencies configurePkgconfigPackages :: Verbosity -> PackageDescription -> ProgramConfiguration -> IO (PackageDescription, ProgramConfiguration) configurePkgconfigPackages verbosity pkg_descr conf | null allpkgs = return (pkg_descr, conf) | otherwise = do (_, _, conf') <- requireProgramVersion (lessVerbose verbosity) pkgConfigProgram (orLaterVersion $ Version [0,9,0] []) conf mapM_ requirePkg allpkgs lib' <- mapM addPkgConfigBILib (library pkg_descr) exes' <- mapM addPkgConfigBIExe (executables pkg_descr) tests' <- mapM addPkgConfigBITest (testSuites pkg_descr) benches' <- mapM addPkgConfigBIBench (benchmarks pkg_descr) let pkg_descr' = pkg_descr { library = lib', executables = exes', testSuites = tests', benchmarks = benches' } return (pkg_descr', conf') where allpkgs = concatMap pkgconfigDepends (allBuildInfo pkg_descr) pkgconfig = rawSystemProgramStdoutConf (lessVerbose verbosity) pkgConfigProgram conf requirePkg dep@(Dependency (PackageName pkg) range) = do version <- pkgconfig ["--modversion", pkg] `catchIO` (\_ -> die notFound) `catchExit` (\_ -> die notFound) case simpleParse version of Nothing -> die "parsing output of pkg-config --modversion failed" Just v | not (withinRange v range) -> die (badVersion v) | otherwise -> info verbosity (depSatisfied v) where notFound = "The pkg-config package '" ++ pkg ++ "'" ++ versionRequirement ++ " is required but it could not be found." badVersion v = "The pkg-config package '" ++ pkg ++ "'" ++ versionRequirement ++ " is required but the version installed on the" ++ " system is version " ++ display v depSatisfied v = "Dependency " ++ display dep ++ ": using version " ++ display v versionRequirement | isAnyVersion range = "" | otherwise = " version " ++ display range -- Adds pkgconfig dependencies to the build info for a component addPkgConfigBI compBI setCompBI comp = do bi <- pkgconfigBuildInfo (pkgconfigDepends (compBI comp)) return $ setCompBI comp (compBI comp `mappend` bi) -- Adds pkgconfig dependencies to the build info for a library addPkgConfigBILib = addPkgConfigBI libBuildInfo $ \lib bi -> lib { libBuildInfo = bi } -- Adds pkgconfig dependencies to the build info for an executable addPkgConfigBIExe = addPkgConfigBI buildInfo $ \exe bi -> exe { buildInfo = bi } -- Adds pkgconfig dependencies to the build info for a test suite addPkgConfigBITest = addPkgConfigBI testBuildInfo $ \test bi -> test { testBuildInfo = bi } -- Adds pkgconfig dependencies to the build info for a benchmark addPkgConfigBIBench = addPkgConfigBI benchmarkBuildInfo $ \bench bi -> bench { benchmarkBuildInfo = bi } pkgconfigBuildInfo :: [Dependency] -> IO BuildInfo pkgconfigBuildInfo [] = return mempty pkgconfigBuildInfo pkgdeps = do let pkgs = nub [ display pkg | Dependency pkg _ <- pkgdeps ] ccflags <- pkgconfig ("--cflags" : pkgs) ldflags <- pkgconfig ("--libs" : pkgs) return (ccLdOptionsBuildInfo (words ccflags) (words ldflags)) -- | Makes a 'BuildInfo' from C compiler and linker flags. -- -- This can be used with the output from configuration programs like pkg-config -- and similar package-specific programs like mysql-config, freealut-config etc. -- For example: -- -- > ccflags <- rawSystemProgramStdoutConf verbosity prog conf ["--cflags"] -- > ldflags <- rawSystemProgramStdoutConf verbosity prog conf ["--libs"] -- > return (ccldOptionsBuildInfo (words ccflags) (words ldflags)) -- ccLdOptionsBuildInfo :: [String] -> [String] -> BuildInfo ccLdOptionsBuildInfo cflags ldflags = let (includeDirs', cflags') = partition ("-I" `isPrefixOf`) cflags (extraLibs', ldflags') = partition ("-l" `isPrefixOf`) ldflags (extraLibDirs', ldflags'') = partition ("-L" `isPrefixOf`) ldflags' in mempty { PD.includeDirs = map (drop 2) includeDirs', PD.extraLibs = map (drop 2) extraLibs', PD.extraLibDirs = map (drop 2) extraLibDirs', PD.ccOptions = cflags', PD.ldOptions = ldflags'' } -- ----------------------------------------------------------------------------- -- Determining the compiler details configCompilerAuxEx :: ConfigFlags -> IO (Compiler, Platform, ProgramConfiguration) configCompilerAuxEx cfg = configCompilerEx (flagToMaybe $ configHcFlavor cfg) (flagToMaybe $ configHcPath cfg) (flagToMaybe $ configHcPkg cfg) programsConfig (fromFlag (configVerbosity cfg)) where programsConfig = mkProgramsConfig cfg defaultProgramConfiguration configCompilerEx :: Maybe CompilerFlavor -> Maybe FilePath -> Maybe FilePath -> ProgramConfiguration -> Verbosity -> IO (Compiler, Platform, ProgramConfiguration) configCompilerEx Nothing _ _ _ _ = die "Unknown compiler" configCompilerEx (Just hcFlavor) hcPath hcPkg conf verbosity = do (comp, maybePlatform, programsConfig) <- case hcFlavor of GHC -> GHC.configure verbosity hcPath hcPkg conf GHCJS -> GHCJS.configure verbosity hcPath hcPkg conf JHC -> JHC.configure verbosity hcPath hcPkg conf LHC -> do (_, _, ghcConf) <- GHC.configure verbosity Nothing hcPkg conf LHC.configure verbosity hcPath Nothing ghcConf UHC -> UHC.configure verbosity hcPath hcPkg conf HaskellSuite {} -> HaskellSuite.configure verbosity hcPath hcPkg conf _ -> die "Unknown compiler" return (comp, fromMaybe buildPlatform maybePlatform, programsConfig) -- Ideally we would like to not have separate configCompiler* and -- configCompiler*Ex sets of functions, but there are many custom setup scripts -- in the wild that are using them, so the versions with old types are kept for -- backwards compatibility. Platform was added to the return triple in 1.18. {-# DEPRECATED configCompiler "'configCompiler' is deprecated. Use 'configCompilerEx' instead." #-} configCompiler :: Maybe CompilerFlavor -> Maybe FilePath -> Maybe FilePath -> ProgramConfiguration -> Verbosity -> IO (Compiler, ProgramConfiguration) configCompiler mFlavor hcPath hcPkg conf verbosity = fmap (\(a,_,b) -> (a,b)) $ configCompilerEx mFlavor hcPath hcPkg conf verbosity {-# DEPRECATED configCompilerAux "configCompilerAux is deprecated. Use 'configCompilerAuxEx' instead." #-} configCompilerAux :: ConfigFlags -> IO (Compiler, ProgramConfiguration) configCompilerAux = fmap (\(a,_,b) -> (a,b)) . configCompilerAuxEx -- ----------------------------------------------------------------------------- -- Making the internal component graph mkComponentsGraph :: PackageDescription -> [PackageId] -> Either [ComponentName] [(Component, [ComponentName])] mkComponentsGraph pkg_descr internalPkgDeps = let graph = [ (c, componentName c, componentDeps c) | c <- pkgEnabledComponents pkg_descr ] in case checkComponentsCyclic graph of Just ccycle -> Left [ cname | (_,cname,_) <- ccycle ] Nothing -> Right [ (c, cdeps) | (c, _, cdeps) <- graph ] where -- The dependencies for the given component componentDeps component = [ CExeName toolname | Dependency (PackageName toolname) _ <- buildTools bi , toolname `elem` map exeName (executables pkg_descr) ] ++ [ CLibName | Dependency pkgname _ <- targetBuildDepends bi , pkgname `elem` map packageName internalPkgDeps ] where bi = componentBuildInfo component reportComponentCycle :: [ComponentName] -> IO a reportComponentCycle cnames = die $ "Components in the package depend on each other in a cyclic way:\n " ++ intercalate " depends on " [ "'" ++ showComponentName cname ++ "'" | cname <- cnames ++ [head cnames] ] mkComponentsLocalBuildInfo :: InstalledPackageIndex -> PackageDescription -> [PackageId] -- internal package deps -> [InstalledPackageInfo] -- external package deps -> [InstalledPackageInfo] -- hole package deps -> Map ModuleName (InstalledPackageInfo, ModuleName) -> PackageKey -> [(Component, [ComponentName])] -> Either [(ModuleReexport, String)] -- errors [(ComponentName, ComponentLocalBuildInfo, [ComponentName])] -- ok mkComponentsLocalBuildInfo installedPackages pkg_descr internalPkgDeps externalPkgDeps holePkgDeps hole_insts pkg_key graph = sequence [ do clbi <- componentLocalBuildInfo c return (componentName c, clbi, cdeps) | (c, cdeps) <- graph ] where -- The allPkgDeps contains all the package deps for the whole package -- but we need to select the subset for this specific component. -- we just take the subset for the package names this component -- needs. Note, this only works because we cannot yet depend on two -- versions of the same package. componentLocalBuildInfo component = case component of CLib lib -> do let exports = map (\n -> Installed.ExposedModule n Nothing Nothing) (PD.exposedModules lib) esigs = map (\n -> Installed.ExposedModule n Nothing (fmap (\(pkg,m) -> Installed.OriginalModule (Installed.installedPackageId pkg) m) (Map.lookup n hole_insts))) (PD.exposedSignatures lib) reexports <- resolveModuleReexports installedPackages (packageId pkg_descr) externalPkgDeps lib return LibComponentLocalBuildInfo { componentPackageDeps = cpds, componentLibraries = [ LibraryName ("HS" ++ packageKeyLibraryName (package pkg_descr) pkg_key) ], componentPackageRenaming = cprns, componentExposedModules = exports ++ reexports ++ esigs } CExe _ -> return ExeComponentLocalBuildInfo { componentPackageDeps = cpds, componentPackageRenaming = cprns } CTest _ -> return TestComponentLocalBuildInfo { componentPackageDeps = cpds, componentPackageRenaming = cprns } CBench _ -> return BenchComponentLocalBuildInfo { componentPackageDeps = cpds, componentPackageRenaming = cprns } where bi = componentBuildInfo component dedup = Map.toList . Map.fromList cpds = if newPackageDepsBehaviour pkg_descr then dedup $ [ (Installed.installedPackageId pkg, packageId pkg) | pkg <- selectSubset bi externalPkgDeps ] ++ [ (inplacePackageId pkgid, pkgid) | pkgid <- selectSubset bi internalPkgDeps ] ++ [ (Installed.installedPackageId pkg, packageId pkg) | pkg <- holePkgDeps ] else [ (Installed.installedPackageId pkg, packageId pkg) | pkg <- externalPkgDeps ] cprns = if newPackageDepsBehaviour pkg_descr then Map.unionWith mappend -- We need hole dependencies passed to GHC, so add them here -- (but note that they're fully thinned out. If they -- appeared legitimately the monoid instance will -- fill them out. (Map.fromList [(packageName pkg, mempty) | pkg <- holePkgDeps]) (targetBuildRenaming bi) -- Hack: if we have old package-deps behavior, it's impossible -- for non-default renamings to be used, because the Cabal -- version is too early. This is a good, because while all the -- deps were bundled up in buildDepends, we didn't do this for -- renamings, so it's not even clear how to get the merged -- version. So just assume that all of them are the default.. else Map.fromList (map (\(_,pid) -> (packageName pid, defaultRenaming)) cpds) selectSubset :: Package pkg => BuildInfo -> [pkg] -> [pkg] selectSubset bi pkgs = [ pkg | pkg <- pkgs, packageName pkg `elem` names bi ] names bi = [ name | Dependency name _ <- targetBuildDepends bi ] -- | Given the author-specified re-export declarations from the .cabal file, -- resolve them to the form that we need for the package database. -- -- An invariant of the package database is that we always link the re-export -- directly to its original defining location (rather than indirectly via a -- chain of re-exporting packages). -- resolveModuleReexports :: InstalledPackageIndex -> PackageId -> [InstalledPackageInfo] -> Library -> Either [(ModuleReexport, String)] -- errors [Installed.ExposedModule] -- ok resolveModuleReexports installedPackages srcpkgid externalPkgDeps lib = case partitionEithers (map resolveModuleReexport (PD.reexportedModules lib)) of ([], ok) -> Right ok (errs, _) -> Left errs where -- A mapping from visible module names to their original defining -- module name. We also record the package name of the package which -- *immediately* provided the module (not the original) to handle if the -- user explicitly says which build-depends they want to reexport from. visibleModules :: Map ModuleName [(PackageName, Installed.ExposedModule)] visibleModules = Map.fromListWith (++) $ [ (Installed.exposedName exposedModule, [(exportingPackageName, exposedModule)]) -- The package index here contains all the indirect deps of the -- package we're configuring, but we want just the direct deps | let directDeps = Set.fromList (map Installed.installedPackageId externalPkgDeps) , pkg <- PackageIndex.allPackages installedPackages , Installed.installedPackageId pkg `Set.member` directDeps , let exportingPackageName = packageName pkg , exposedModule <- visibleModuleDetails pkg ] ++ [ (visibleModuleName, [(exportingPackageName, exposedModule)]) | visibleModuleName <- PD.exposedModules lib ++ otherModules (libBuildInfo lib) , let exportingPackageName = packageName srcpkgid definingModuleName = visibleModuleName -- we don't know the InstalledPackageId of this package yet -- we will fill it in later, before registration. definingPackageId = InstalledPackageId "" originalModule = Installed.OriginalModule definingPackageId definingModuleName exposedModule = Installed.ExposedModule visibleModuleName (Just originalModule) Nothing ] -- All the modules exported from this package and their defining name and -- package (either defined here in this package or re-exported from some -- other package). Return an ExposedModule because we want to hold onto -- signature information. visibleModuleDetails :: InstalledPackageInfo -> [Installed.ExposedModule] visibleModuleDetails pkg = do exposedModule <- Installed.exposedModules pkg case Installed.exposedReexport exposedModule of -- The first case is the modules actually defined in this package. -- In this case the reexport will point to this package. Nothing -> return exposedModule { Installed.exposedReexport = Just (Installed.OriginalModule (Installed.installedPackageId pkg) (Installed.exposedName exposedModule)) } -- On the other hand, a visible module might actually be itself -- a re-export! In this case, the re-export info for the package -- doing the re-export will point us to the original defining -- module name and package, so we can reuse the entry. Just _ -> return exposedModule resolveModuleReexport reexport@ModuleReexport { moduleReexportOriginalPackage = moriginalPackageName, moduleReexportOriginalName = originalName, moduleReexportName = newName } = let filterForSpecificPackage = case moriginalPackageName of Nothing -> id Just originalPackageName -> filter (\(pkgname, _) -> pkgname == originalPackageName) matches = filterForSpecificPackage (Map.findWithDefault [] originalName visibleModules) in case (matches, moriginalPackageName) of ((_, exposedModule):rest, _) -- TODO: Refine this check for signatures | all (\(_, exposedModule') -> Installed.exposedReexport exposedModule == Installed.exposedReexport exposedModule') rest -> Right exposedModule { Installed.exposedName = newName } ([], Just originalPackageName) -> Left $ (,) reexport $ "The package " ++ display originalPackageName ++ " does not export a module " ++ display originalName ([], Nothing) -> Left $ (,) reexport $ "The module " ++ display originalName ++ " is not exported by any suitable package (this package " ++ "itself nor any of its 'build-depends' dependencies)." (ms, _) -> Left $ (,) reexport $ "The module " ++ display originalName ++ " is exported " ++ "by more than one package (" ++ intercalate ", " [ display pkgname | (pkgname,_) <- ms ] ++ ") and so the re-export is ambiguous. The ambiguity can " ++ "be resolved by qualifying by the package name. The " ++ "syntax is 'packagename:moduleName [as newname]'." -- Note: if in future Cabal allows directly depending on multiple -- instances of the same package (e.g. backpack) then an additional -- ambiguity case is possible here: (_, Just originalPackageName) -- with the module being ambigious despite being qualified by a -- package name. Presumably by that time we'll have a mechanism to -- qualify the instance we're referring to. reportModuleReexportProblems :: [(ModuleReexport, String)] -> IO a reportModuleReexportProblems reexportProblems = die $ unlines [ "Problem with the module re-export '" ++ display reexport ++ "': " ++ msg | (reexport, msg) <- reexportProblems ] -- ----------------------------------------------------------------------------- -- Testing C lib and header dependencies -- Try to build a test C program which includes every header and links every -- lib. If that fails, try to narrow it down by preprocessing (only) and linking -- with individual headers and libs. If none is the obvious culprit then give a -- generic error message. -- TODO: produce a log file from the compiler errors, if any. checkForeignDeps :: PackageDescription -> LocalBuildInfo -> Verbosity -> IO () checkForeignDeps pkg lbi verbosity = do ifBuildsWith allHeaders (commonCcArgs ++ makeLdArgs allLibs) -- I'm feeling -- lucky (return ()) (do missingLibs <- findMissingLibs missingHdr <- findOffendingHdr explainErrors missingHdr missingLibs) where allHeaders = collectField PD.includes allLibs = collectField PD.extraLibs ifBuildsWith headers args success failure = do ok <- builds (makeProgram headers) args if ok then success else failure findOffendingHdr = ifBuildsWith allHeaders ccArgs (return Nothing) (go . tail . inits $ allHeaders) where go [] = return Nothing -- cannot happen go (hdrs:hdrsInits) = -- Try just preprocessing first ifBuildsWith hdrs cppArgs -- If that works, try compiling too (ifBuildsWith hdrs ccArgs (go hdrsInits) (return . Just . Right . last $ hdrs)) (return . Just . Left . last $ hdrs) cppArgs = "-E":commonCppArgs -- preprocess only ccArgs = "-c":commonCcArgs -- don't try to link findMissingLibs = ifBuildsWith [] (makeLdArgs allLibs) (return []) (filterM (fmap not . libExists) allLibs) libExists lib = builds (makeProgram []) (makeLdArgs [lib]) commonCppArgs = platformDefines lbi ++ [ "-I" ++ autogenModulesDir lbi ] ++ [ "-I" ++ dir | dir <- collectField PD.includeDirs ] ++ ["-I."] ++ collectField PD.cppOptions ++ collectField PD.ccOptions ++ [ "-I" ++ dir | dep <- deps , dir <- Installed.includeDirs dep ] ++ [ opt | dep <- deps , opt <- Installed.ccOptions dep ] commonCcArgs = commonCppArgs ++ collectField PD.ccOptions ++ [ opt | dep <- deps , opt <- Installed.ccOptions dep ] commonLdArgs = [ "-L" ++ dir | dir <- collectField PD.extraLibDirs ] ++ collectField PD.ldOptions ++ [ "-L" ++ dir | dep <- deps , dir <- Installed.libraryDirs dep ] --TODO: do we also need dependent packages' ld options? makeLdArgs libs = [ "-l"++lib | lib <- libs ] ++ commonLdArgs makeProgram hdrs = unlines $ [ "#include \"" ++ hdr ++ "\"" | hdr <- hdrs ] ++ ["int main(int argc, char** argv) { return 0; }"] collectField f = concatMap f allBi allBi = allBuildInfo pkg deps = PackageIndex.topologicalOrder (installedPkgs lbi) builds program args = do tempDir <- getTemporaryDirectory withTempFile tempDir ".c" $ \cName cHnd -> withTempFile tempDir "" $ \oNname oHnd -> do hPutStrLn cHnd program hClose cHnd hClose oHnd _ <- rawSystemProgramStdoutConf verbosity gccProgram (withPrograms lbi) (cName:"-o":oNname:args) return True `catchIO` (\_ -> return False) `catchExit` (\_ -> return False) explainErrors Nothing [] = return () -- should be impossible! explainErrors _ _ | isNothing . lookupProgram gccProgram . withPrograms $ lbi = die $ unlines $ [ "No working gcc", "This package depends on foreign library but we cannot " ++ "find a working C compiler. If you have it in a " ++ "non-standard location you can use the --with-gcc " ++ "flag to specify it." ] explainErrors hdr libs = die $ unlines $ [ if plural then "Missing dependencies on foreign libraries:" else "Missing dependency on a foreign library:" | missing ] ++ case hdr of Just (Left h) -> ["* Missing (or bad) header file: " ++ h ] _ -> [] ++ case libs of [] -> [] [lib] -> ["* Missing C library: " ++ lib] _ -> ["* Missing C libraries: " ++ intercalate ", " libs] ++ [if plural then messagePlural else messageSingular | missing] ++ case hdr of Just (Left _) -> [ headerCppMessage ] Just (Right h) -> [ (if missing then "* " else "") ++ "Bad header file: " ++ h , headerCcMessage ] _ -> [] where plural = length libs >= 2 -- Is there something missing? (as opposed to broken) missing = not (null libs) || case hdr of Just (Left _) -> True; _ -> False messageSingular = "This problem can usually be solved by installing the system " ++ "package that provides this library (you may need the " ++ "\"-dev\" version). If the library is already installed " ++ "but in a non-standard location then you can use the flags " ++ "--extra-include-dirs= and --extra-lib-dirs= to specify " ++ "where it is." messagePlural = "This problem can usually be solved by installing the system " ++ "packages that provide these libraries (you may need the " ++ "\"-dev\" versions). If the libraries are already installed " ++ "but in a non-standard location then you can use the flags " ++ "--extra-include-dirs= and --extra-lib-dirs= to specify " ++ "where they are." headerCppMessage = "If the header file does exist, it may contain errors that " ++ "are caught by the C compiler at the preprocessing stage. " ++ "In this case you can re-run configure with the verbosity " ++ "flag -v3 to see the error messages." headerCcMessage = "The header file contains a compile error. " ++ "You can re-run configure with the verbosity flag " ++ "-v3 to see the error messages from the C compiler." -- | Output package check warnings and errors. Exit if any errors. checkPackageProblems :: Verbosity -> GenericPackageDescription -> PackageDescription -> IO () checkPackageProblems verbosity gpkg pkg = do ioChecks <- checkPackageFiles pkg "." let pureChecks = checkPackage gpkg (Just pkg) errors = [ e | PackageBuildImpossible e <- pureChecks ++ ioChecks ] warnings = [ w | PackageBuildWarning w <- pureChecks ++ ioChecks ] if null errors then mapM_ (warn verbosity) warnings else die (intercalate "\n\n" errors) -- | Preform checks if a relocatable build is allowed checkRelocatable :: Verbosity -> PackageDescription -> LocalBuildInfo -> IO () checkRelocatable verbosity pkg lbi = sequence_ [ checkOS , checkCompiler , packagePrefixRelative , depsPrefixRelative ] where -- Check if the OS support relocatable builds. -- -- If you add new OS' to this list, and your OS supports dynamic libraries -- and RPATH, make sure you add your OS to RPATH-support list of: -- Distribution.Simple.GHC.getRPaths checkOS = unless (os `elem` [ OSX, Linux ]) $ die $ "Operating system: " ++ display os ++ ", does not support relocatable builds" where (Platform _ os) = hostPlatform lbi -- Check if the Compiler support relocatable builds checkCompiler = unless (compilerFlavor comp `elem` [ GHC ]) $ die $ "Compiler: " ++ show comp ++ ", does not support relocatable builds" where comp = compiler lbi -- Check if all the install dirs are relative to same prefix packagePrefixRelative = unless (relativeInstallDirs installDirs) $ die $ "Installation directories are not prefix_relative:\n" ++ show installDirs where installDirs = absoluteInstallDirs pkg lbi NoCopyDest p = prefix installDirs relativeInstallDirs (InstallDirs {..}) = all isJust (fmap (stripPrefix p) [ bindir, libdir, dynlibdir, libexecdir, includedir, datadir , docdir, mandir, htmldir, haddockdir, sysconfdir] ) -- Check if the library dirs of the dependencies that are in the package -- database to which the package is installed are relative to the -- prefix of the package depsPrefixRelative = do pkgr <- GHC.pkgRoot verbosity lbi (last (withPackageDB lbi)) mapM_ (doCheck pkgr) ipkgs where doCheck pkgr ipkg | maybe False (== pkgr) (Installed.pkgRoot ipkg) = mapM_ (\l -> when (isNothing $ stripPrefix p l) (die (msg l))) (Installed.libraryDirs ipkg) | otherwise = return () installDirs = absoluteInstallDirs pkg lbi NoCopyDest p = prefix installDirs ipkgs = PackageIndex.allPackages (installedPkgs lbi) msg l = "Library directory of a dependency: " ++ show l ++ "\nis not relative to the installation prefix:\n" ++ show p Cabal-1.22.5.0/Distribution/Simple/GHC.hs0000644000000000000000000014211712627136220016003 0ustar0000000000000000{-# LANGUAGE CPP #-} ----------------------------------------------------------------------------- -- | -- Module : Distribution.Simple.GHC -- Copyright : Isaac Jones 2003-2007 -- License : BSD3 -- -- Maintainer : cabal-devel@haskell.org -- Portability : portable -- -- This is a fairly large module. It contains most of the GHC-specific code for -- configuring, building and installing packages. It also exports a function -- for finding out what packages are already installed. Configuring involves -- finding the @ghc@ and @ghc-pkg@ programs, finding what language extensions -- this version of ghc supports and returning a 'Compiler' value. -- -- 'getInstalledPackages' involves calling the @ghc-pkg@ program to find out -- what packages are installed. -- -- Building is somewhat complex as there is quite a bit of information to take -- into account. We have to build libs and programs, possibly for profiling and -- shared libs. We have to support building libraries that will be usable by -- GHCi and also ghc's @-split-objs@ feature. We have to compile any C files -- using ghc. Linking, especially for @split-objs@ is remarkably complex, -- partly because there tend to be 1,000's of @.o@ files and this can often be -- more than we can pass to the @ld@ or @ar@ programs in one go. -- -- Installing for libs and exes involves finding the right files and copying -- them to the right places. One of the more tricky things about this module is -- remembering the layout of files in the build directory (which is not -- explicitly documented) and thus what search dirs are used for various kinds -- of files. module Distribution.Simple.GHC ( getGhcInfo, configure, getInstalledPackages, getPackageDBContents, buildLib, buildExe, replLib, replExe, startInterpreter, installLib, installExe, libAbiHash, hcPkgInfo, registerPackage, componentGhcOptions, getLibDir, isDynamic, getGlobalPackageDB, pkgRoot ) where import qualified Distribution.Simple.GHC.IPI641 as IPI641 import qualified Distribution.Simple.GHC.IPI642 as IPI642 import qualified Distribution.Simple.GHC.Internal as Internal import Distribution.Simple.GHC.ImplInfo import Distribution.PackageDescription as PD ( PackageDescription(..), BuildInfo(..), Executable(..), Library(..) , allExtensions, libModules, exeModules , hcOptions, hcSharedOptions, hcProfOptions ) import Distribution.InstalledPackageInfo ( InstalledPackageInfo ) import qualified Distribution.InstalledPackageInfo as InstalledPackageInfo ( InstalledPackageInfo_(..) ) import Distribution.Simple.PackageIndex (InstalledPackageIndex) import qualified Distribution.Simple.PackageIndex as PackageIndex import Distribution.Simple.LocalBuildInfo ( LocalBuildInfo(..), ComponentLocalBuildInfo(..) , absoluteInstallDirs, depLibraryPaths ) import qualified Distribution.Simple.Hpc as Hpc import Distribution.Simple.InstallDirs hiding ( absoluteInstallDirs ) import Distribution.Simple.BuildPaths import Distribution.Simple.Utils import Distribution.Package ( PackageName(..) ) import qualified Distribution.ModuleName as ModuleName import Distribution.Simple.Program ( Program(..), ConfiguredProgram(..), ProgramConfiguration , ProgramSearchPath , rawSystemProgramStdout, rawSystemProgramStdoutConf , getProgramInvocationOutput, requireProgramVersion, requireProgram , userMaybeSpecifyPath, programPath, lookupProgram, addKnownProgram , ghcProgram, ghcPkgProgram, hsc2hsProgram, ldProgram ) import qualified Distribution.Simple.Program.HcPkg as HcPkg import qualified Distribution.Simple.Program.Ar as Ar import qualified Distribution.Simple.Program.Ld as Ld import qualified Distribution.Simple.Program.Strip as Strip import Distribution.Simple.Program.GHC import Distribution.Simple.Setup ( toFlag, fromFlag, fromFlagOrDefault, configCoverage, configDistPref ) import qualified Distribution.Simple.Setup as Cabal ( Flag(..) ) import Distribution.Simple.Compiler ( CompilerFlavor(..), CompilerId(..), Compiler(..), compilerVersion , PackageDB(..), PackageDBStack, AbiTag(..) ) import Distribution.Version ( Version(..), anyVersion, orLaterVersion ) import Distribution.System ( Platform(..), OS(..) ) import Distribution.Verbosity import Distribution.Text ( display ) import Distribution.Utils.NubList ( NubListR, overNubListR, toNubListR ) import Language.Haskell.Extension (Extension(..), KnownExtension(..)) import Control.Monad ( unless, when ) import Data.Char ( isDigit, isSpace ) import Data.List import qualified Data.Map as M ( fromList ) import Data.Maybe ( catMaybes ) #if __GLASGOW_HASKELL__ < 710 import Data.Monoid ( Monoid(..) ) #endif import Data.Version ( showVersion ) import System.Directory ( doesFileExist, getAppUserDataDirectory, createDirectoryIfMissing ) import System.FilePath ( (), (<.>), takeExtension, takeDirectory, replaceExtension, splitExtension, isRelative ) import qualified System.Info -- ----------------------------------------------------------------------------- -- Configuring configure :: Verbosity -> Maybe FilePath -> Maybe FilePath -> ProgramConfiguration -> IO (Compiler, Maybe Platform, ProgramConfiguration) configure verbosity hcPath hcPkgPath conf0 = do (ghcProg, ghcVersion, conf1) <- requireProgramVersion verbosity ghcProgram (orLaterVersion (Version [6,4] [])) (userMaybeSpecifyPath "ghc" hcPath conf0) let implInfo = ghcVersionImplInfo ghcVersion -- This is slightly tricky, we have to configure ghc first, then we use the -- location of ghc to help find ghc-pkg in the case that the user did not -- specify the location of ghc-pkg directly: (ghcPkgProg, ghcPkgVersion, conf2) <- requireProgramVersion verbosity ghcPkgProgram { programFindLocation = guessGhcPkgFromGhcPath ghcProg } anyVersion (userMaybeSpecifyPath "ghc-pkg" hcPkgPath conf1) when (ghcVersion /= ghcPkgVersion) $ die $ "Version mismatch between ghc and ghc-pkg: " ++ programPath ghcProg ++ " is version " ++ display ghcVersion ++ " " ++ programPath ghcPkgProg ++ " is version " ++ display ghcPkgVersion -- Likewise we try to find the matching hsc2hs program. let hsc2hsProgram' = hsc2hsProgram { programFindLocation = guessHsc2hsFromGhcPath ghcProg } conf3 = addKnownProgram hsc2hsProgram' conf2 languages <- Internal.getLanguages verbosity implInfo ghcProg extensions <- Internal.getExtensions verbosity implInfo ghcProg ghcInfo <- Internal.getGhcInfo verbosity implInfo ghcProg let ghcInfoMap = M.fromList ghcInfo let comp = Compiler { compilerId = CompilerId GHC ghcVersion, compilerAbiTag = NoAbiTag, compilerCompat = [], compilerLanguages = languages, compilerExtensions = extensions, compilerProperties = ghcInfoMap } compPlatform = Internal.targetPlatform ghcInfo conf4 = Internal.configureToolchain implInfo ghcProg ghcInfoMap conf3 -- configure gcc and ld return (comp, compPlatform, conf4) -- | Given something like /usr/local/bin/ghc-6.6.1(.exe) we try and find -- the corresponding tool; e.g. if the tool is ghc-pkg, we try looking -- for a versioned or unversioned ghc-pkg in the same dir, that is: -- -- > /usr/local/bin/ghc-pkg-ghc-6.6.1(.exe) -- > /usr/local/bin/ghc-pkg-6.6.1(.exe) -- > /usr/local/bin/ghc-pkg(.exe) -- guessToolFromGhcPath :: Program -> ConfiguredProgram -> Verbosity -> ProgramSearchPath -> IO (Maybe FilePath) guessToolFromGhcPath tool ghcProg verbosity searchpath = do let toolname = programName tool path = programPath ghcProg dir = takeDirectory path versionSuffix = takeVersionSuffix (dropExeExtension path) guessNormal = dir toolname <.> exeExtension guessGhcVersioned = dir (toolname ++ "-ghc" ++ versionSuffix) <.> exeExtension guessVersioned = dir (toolname ++ versionSuffix) <.> exeExtension guesses | null versionSuffix = [guessNormal] | otherwise = [guessGhcVersioned, guessVersioned, guessNormal] info verbosity $ "looking for tool " ++ toolname ++ " near compiler in " ++ dir exists <- mapM doesFileExist guesses case [ file | (file, True) <- zip guesses exists ] of -- If we can't find it near ghc, fall back to the usual -- method. [] -> programFindLocation tool verbosity searchpath (fp:_) -> do info verbosity $ "found " ++ toolname ++ " in " ++ fp return (Just fp) where takeVersionSuffix :: FilePath -> String takeVersionSuffix = takeWhileEndLE isSuffixChar isSuffixChar :: Char -> Bool isSuffixChar c = isDigit c || c == '.' || c == '-' dropExeExtension :: FilePath -> FilePath dropExeExtension filepath = case splitExtension filepath of (filepath', extension) | extension == exeExtension -> filepath' | otherwise -> filepath -- | Given something like /usr/local/bin/ghc-6.6.1(.exe) we try and find a -- corresponding ghc-pkg, we try looking for both a versioned and unversioned -- ghc-pkg in the same dir, that is: -- -- > /usr/local/bin/ghc-pkg-ghc-6.6.1(.exe) -- > /usr/local/bin/ghc-pkg-6.6.1(.exe) -- > /usr/local/bin/ghc-pkg(.exe) -- guessGhcPkgFromGhcPath :: ConfiguredProgram -> Verbosity -> ProgramSearchPath -> IO (Maybe FilePath) guessGhcPkgFromGhcPath = guessToolFromGhcPath ghcPkgProgram -- | Given something like /usr/local/bin/ghc-6.6.1(.exe) we try and find a -- corresponding hsc2hs, we try looking for both a versioned and unversioned -- hsc2hs in the same dir, that is: -- -- > /usr/local/bin/hsc2hs-ghc-6.6.1(.exe) -- > /usr/local/bin/hsc2hs-6.6.1(.exe) -- > /usr/local/bin/hsc2hs(.exe) -- guessHsc2hsFromGhcPath :: ConfiguredProgram -> Verbosity -> ProgramSearchPath -> IO (Maybe FilePath) guessHsc2hsFromGhcPath = guessToolFromGhcPath hsc2hsProgram getGhcInfo :: Verbosity -> ConfiguredProgram -> IO [(String, String)] getGhcInfo verbosity ghcProg = Internal.getGhcInfo verbosity implInfo ghcProg where Just version = programVersion ghcProg implInfo = ghcVersionImplInfo version -- | Given a single package DB, return all installed packages. getPackageDBContents :: Verbosity -> PackageDB -> ProgramConfiguration -> IO InstalledPackageIndex getPackageDBContents verbosity packagedb conf = do pkgss <- getInstalledPackages' verbosity [packagedb] conf toPackageIndex verbosity pkgss conf -- | Given a package DB stack, return all installed packages. getInstalledPackages :: Verbosity -> PackageDBStack -> ProgramConfiguration -> IO InstalledPackageIndex getInstalledPackages verbosity packagedbs conf = do checkPackageDbEnvVar checkPackageDbStack packagedbs pkgss <- getInstalledPackages' verbosity packagedbs conf index <- toPackageIndex verbosity pkgss conf return $! hackRtsPackage index where hackRtsPackage index = case PackageIndex.lookupPackageName index (PackageName "rts") of [(_,[rts])] -> PackageIndex.insert (removeMingwIncludeDir rts) index _ -> index -- No (or multiple) ghc rts package is registered!! -- Feh, whatever, the ghc test suite does some crazy stuff. -- | Given a list of @(PackageDB, InstalledPackageInfo)@ pairs, produce a -- @PackageIndex@. Helper function used by 'getPackageDBContents' and -- 'getInstalledPackages'. toPackageIndex :: Verbosity -> [(PackageDB, [InstalledPackageInfo])] -> ProgramConfiguration -> IO InstalledPackageIndex toPackageIndex verbosity pkgss conf = do -- On Windows, various fields have $topdir/foo rather than full -- paths. We need to substitute the right value in so that when -- we, for example, call gcc, we have proper paths to give it. topDir <- getLibDir' verbosity ghcProg let indices = [ PackageIndex.fromList (map (Internal.substTopDir topDir) pkgs) | (_, pkgs) <- pkgss ] return $! (mconcat indices) where Just ghcProg = lookupProgram ghcProgram conf getLibDir :: Verbosity -> LocalBuildInfo -> IO FilePath getLibDir verbosity lbi = dropWhileEndLE isSpace `fmap` rawSystemProgramStdoutConf verbosity ghcProgram (withPrograms lbi) ["--print-libdir"] getLibDir' :: Verbosity -> ConfiguredProgram -> IO FilePath getLibDir' verbosity ghcProg = dropWhileEndLE isSpace `fmap` rawSystemProgramStdout verbosity ghcProg ["--print-libdir"] -- | Return the 'FilePath' to the global GHC package database. getGlobalPackageDB :: Verbosity -> ConfiguredProgram -> IO FilePath getGlobalPackageDB verbosity ghcProg = dropWhileEndLE isSpace `fmap` rawSystemProgramStdout verbosity ghcProg ["--print-global-package-db"] checkPackageDbEnvVar :: IO () checkPackageDbEnvVar = Internal.checkPackageDbEnvVar "GHC" "GHC_PACKAGE_PATH" checkPackageDbStack :: PackageDBStack -> IO () checkPackageDbStack (GlobalPackageDB:rest) | GlobalPackageDB `notElem` rest = return () checkPackageDbStack rest | GlobalPackageDB `notElem` rest = die $ "With current ghc versions the global package db is always used " ++ "and must be listed first. This ghc limitation may be lifted in " ++ "future, see http://hackage.haskell.org/trac/ghc/ticket/5977" checkPackageDbStack _ = die $ "If the global package db is specified, it must be " ++ "specified first and cannot be specified multiple times" -- GHC < 6.10 put "$topdir/include/mingw" in rts's installDirs. This -- breaks when you want to use a different gcc, so we need to filter -- it out. removeMingwIncludeDir :: InstalledPackageInfo -> InstalledPackageInfo removeMingwIncludeDir pkg = let ids = InstalledPackageInfo.includeDirs pkg ids' = filter (not . ("mingw" `isSuffixOf`)) ids in pkg { InstalledPackageInfo.includeDirs = ids' } -- | Get the packages from specific PackageDBs, not cumulative. -- getInstalledPackages' :: Verbosity -> [PackageDB] -> ProgramConfiguration -> IO [(PackageDB, [InstalledPackageInfo])] getInstalledPackages' verbosity packagedbs conf | ghcVersion >= Version [6,9] [] = sequence [ do pkgs <- HcPkg.dump (hcPkgInfo conf) verbosity packagedb return (packagedb, pkgs) | packagedb <- packagedbs ] where Just ghcProg = lookupProgram ghcProgram conf Just ghcVersion = programVersion ghcProg getInstalledPackages' verbosity packagedbs conf = do str <- rawSystemProgramStdoutConf verbosity ghcPkgProgram conf ["list"] let pkgFiles = [ init line | line <- lines str, last line == ':' ] dbFile packagedb = case (packagedb, pkgFiles) of (GlobalPackageDB, global:_) -> return $ Just global (UserPackageDB, _global:user:_) -> return $ Just user (UserPackageDB, _global:_) -> return $ Nothing (SpecificPackageDB specific, _) -> return $ Just specific _ -> die "cannot read ghc-pkg package listing" pkgFiles' <- mapM dbFile packagedbs sequence [ withFileContents file $ \content -> do pkgs <- readPackages file content return (db, pkgs) | (db , Just file) <- zip packagedbs pkgFiles' ] where -- Depending on the version of ghc we use a different type's Read -- instance to parse the package file and then convert. -- It's a bit yuck. But that's what we get for using Read/Show. readPackages | ghcVersion >= Version [6,4,2] [] = \file content -> case reads content of [(pkgs, _)] -> return (map IPI642.toCurrent pkgs) _ -> failToRead file | otherwise = \file content -> case reads content of [(pkgs, _)] -> return (map IPI641.toCurrent pkgs) _ -> failToRead file Just ghcProg = lookupProgram ghcProgram conf Just ghcVersion = programVersion ghcProg failToRead file = die $ "cannot read ghc package database " ++ file -- ----------------------------------------------------------------------------- -- Building -- | Build a library with GHC. -- buildLib, replLib :: Verbosity -> Cabal.Flag (Maybe Int) -> PackageDescription -> LocalBuildInfo -> Library -> ComponentLocalBuildInfo -> IO () buildLib = buildOrReplLib False replLib = buildOrReplLib True buildOrReplLib :: Bool -> Verbosity -> Cabal.Flag (Maybe Int) -> PackageDescription -> LocalBuildInfo -> Library -> ComponentLocalBuildInfo -> IO () buildOrReplLib forRepl verbosity numJobs pkg_descr lbi lib clbi = do libName <- case componentLibraries clbi of [libName] -> return libName [] -> die "No library name found when building library" _ -> die "Multiple library names found when building library" let libTargetDir = buildDir lbi whenVanillaLib forceVanilla = when (forceVanilla || withVanillaLib lbi) whenProfLib = when (withProfLib lbi) whenSharedLib forceShared = when (forceShared || withSharedLib lbi) whenGHCiLib = when (withGHCiLib lbi && withVanillaLib lbi) ifReplLib = when forRepl comp = compiler lbi ghcVersion = compilerVersion comp implInfo = getImplInfo comp (Platform _hostArch hostOS) = hostPlatform lbi hole_insts = map (\(k,(p,n)) -> (k,(InstalledPackageInfo.packageKey p,n))) (instantiatedWith lbi) (ghcProg, _) <- requireProgram verbosity ghcProgram (withPrograms lbi) let runGhcProg = runGHC verbosity ghcProg comp libBi <- hackThreadedFlag verbosity comp (withProfLib lbi) (libBuildInfo lib) let isGhcDynamic = isDynamic comp dynamicTooSupported = supportsDynamicToo comp doingTH = EnableExtension TemplateHaskell `elem` allExtensions libBi forceVanillaLib = doingTH && not isGhcDynamic forceSharedLib = doingTH && isGhcDynamic -- TH always needs default libs, even when building for profiling -- Determine if program coverage should be enabled and if so, what -- '-hpcdir' should be. let isCoverageEnabled = fromFlag $ configCoverage $ configFlags lbi -- Component name. Not 'libName' because that has the "HS" prefix -- that GHC gives Haskell libraries. cname = display $ PD.package $ localPkgDescr lbi distPref = fromFlag $ configDistPref $ configFlags lbi hpcdir way | isCoverageEnabled = toFlag $ Hpc.mixDir distPref way cname | otherwise = mempty createDirectoryIfMissingVerbose verbosity True libTargetDir -- TODO: do we need to put hs-boot files into place for mutually recursive -- modules? let cObjs = map (`replaceExtension` objExtension) (cSources libBi) baseOpts = componentGhcOptions verbosity lbi libBi clbi libTargetDir vanillaOpts = baseOpts `mappend` mempty { ghcOptMode = toFlag GhcModeMake, ghcOptNumJobs = numJobs, ghcOptPackageKey = toFlag (pkgKey lbi), ghcOptSigOf = hole_insts, ghcOptInputModules = toNubListR $ libModules lib, ghcOptHPCDir = hpcdir Hpc.Vanilla } profOpts = vanillaOpts `mappend` mempty { ghcOptProfilingMode = toFlag True, ghcOptHiSuffix = toFlag "p_hi", ghcOptObjSuffix = toFlag "p_o", ghcOptExtra = toNubListR $ hcProfOptions GHC libBi, ghcOptHPCDir = hpcdir Hpc.Prof } sharedOpts = vanillaOpts `mappend` mempty { ghcOptDynLinkMode = toFlag GhcDynamicOnly, ghcOptFPic = toFlag True, ghcOptHiSuffix = toFlag "dyn_hi", ghcOptObjSuffix = toFlag "dyn_o", ghcOptExtra = toNubListR $ hcSharedOptions GHC libBi, ghcOptHPCDir = hpcdir Hpc.Dyn } linkerOpts = mempty { ghcOptLinkOptions = toNubListR $ PD.ldOptions libBi, ghcOptLinkLibs = toNubListR $ extraLibs libBi, ghcOptLinkLibPath = toNubListR $ extraLibDirs libBi, ghcOptLinkFrameworks = toNubListR $ PD.frameworks libBi, ghcOptInputFiles = toNubListR [libTargetDir x | x <- cObjs] } replOpts = vanillaOpts { ghcOptExtra = overNubListR Internal.filterGhciFlags $ (ghcOptExtra vanillaOpts), ghcOptNumJobs = mempty } `mappend` linkerOpts `mappend` mempty { ghcOptMode = toFlag GhcModeInteractive, ghcOptOptimisation = toFlag GhcNoOptimisation } vanillaSharedOpts = vanillaOpts `mappend` mempty { ghcOptDynLinkMode = toFlag GhcStaticAndDynamic, ghcOptDynHiSuffix = toFlag "dyn_hi", ghcOptDynObjSuffix = toFlag "dyn_o", ghcOptHPCDir = hpcdir Hpc.Dyn } unless (forRepl || null (libModules lib)) $ do let vanilla = whenVanillaLib forceVanillaLib (runGhcProg vanillaOpts) shared = whenSharedLib forceSharedLib (runGhcProg sharedOpts) useDynToo = dynamicTooSupported && (forceVanillaLib || withVanillaLib lbi) && (forceSharedLib || withSharedLib lbi) && null (hcSharedOptions GHC libBi) if useDynToo then do runGhcProg vanillaSharedOpts case (hpcdir Hpc.Dyn, hpcdir Hpc.Vanilla) of (Cabal.Flag dynDir, Cabal.Flag vanillaDir) -> do -- When the vanilla and shared library builds are done -- in one pass, only one set of HPC module interfaces -- are generated. This set should suffice for both -- static and dynamically linked executables. We copy -- the modules interfaces so they are available under -- both ways. copyDirectoryRecursive verbosity dynDir vanillaDir _ -> return () else if isGhcDynamic then do shared; vanilla else do vanilla; shared whenProfLib (runGhcProg profOpts) -- build any C sources unless (null (cSources libBi)) $ do info verbosity "Building C Sources..." sequence_ [ do let baseCcOpts = Internal.componentCcGhcOptions verbosity implInfo lbi libBi clbi libTargetDir filename vanillaCcOpts = if isGhcDynamic -- Dynamic GHC requires C sources to be built -- with -fPIC for REPL to work. See #2207. then baseCcOpts { ghcOptFPic = toFlag True } else baseCcOpts profCcOpts = vanillaCcOpts `mappend` mempty { ghcOptProfilingMode = toFlag True, ghcOptObjSuffix = toFlag "p_o" } sharedCcOpts = vanillaCcOpts `mappend` mempty { ghcOptFPic = toFlag True, ghcOptDynLinkMode = toFlag GhcDynamicOnly, ghcOptObjSuffix = toFlag "dyn_o" } odir = fromFlag (ghcOptObjDir vanillaCcOpts) createDirectoryIfMissingVerbose verbosity True odir needsRecomp <- checkNeedsRecompilation filename vanillaCcOpts when needsRecomp $ do runGhcProg vanillaCcOpts unless forRepl $ whenSharedLib forceSharedLib (runGhcProg sharedCcOpts) unless forRepl $ whenProfLib (runGhcProg profCcOpts) | filename <- cSources libBi] -- TODO: problem here is we need the .c files built first, so we can load them -- with ghci, but .c files can depend on .h files generated by ghc by ffi -- exports. unless (null (libModules lib)) $ ifReplLib (runGhcProg replOpts) -- link: unless forRepl $ do info verbosity "Linking..." let cProfObjs = map (`replaceExtension` ("p_" ++ objExtension)) (cSources libBi) cSharedObjs = map (`replaceExtension` ("dyn_" ++ objExtension)) (cSources libBi) cid = compilerId (compiler lbi) vanillaLibFilePath = libTargetDir mkLibName libName profileLibFilePath = libTargetDir mkProfLibName libName sharedLibFilePath = libTargetDir mkSharedLibName cid libName ghciLibFilePath = libTargetDir Internal.mkGHCiLibName libName libInstallPath = libdir $ absoluteInstallDirs pkg_descr lbi NoCopyDest sharedLibInstallPath = libInstallPath mkSharedLibName cid libName stubObjs <- fmap catMaybes $ sequence [ findFileWithExtension [objExtension] [libTargetDir] (ModuleName.toFilePath x ++"_stub") | ghcVersion < Version [7,2] [] -- ghc-7.2+ does not make _stub.o files , x <- libModules lib ] stubProfObjs <- fmap catMaybes $ sequence [ findFileWithExtension ["p_" ++ objExtension] [libTargetDir] (ModuleName.toFilePath x ++"_stub") | ghcVersion < Version [7,2] [] -- ghc-7.2+ does not make _stub.o files , x <- libModules lib ] stubSharedObjs <- fmap catMaybes $ sequence [ findFileWithExtension ["dyn_" ++ objExtension] [libTargetDir] (ModuleName.toFilePath x ++"_stub") | ghcVersion < Version [7,2] [] -- ghc-7.2+ does not make _stub.o files , x <- libModules lib ] hObjs <- Internal.getHaskellObjects implInfo lib lbi libTargetDir objExtension True hProfObjs <- if (withProfLib lbi) then Internal.getHaskellObjects implInfo lib lbi libTargetDir ("p_" ++ objExtension) True else return [] hSharedObjs <- if (withSharedLib lbi) then Internal.getHaskellObjects implInfo lib lbi libTargetDir ("dyn_" ++ objExtension) False else return [] unless (null hObjs && null cObjs && null stubObjs) $ do rpaths <- getRPaths lbi clbi let staticObjectFiles = hObjs ++ map (libTargetDir ) cObjs ++ stubObjs profObjectFiles = hProfObjs ++ map (libTargetDir ) cProfObjs ++ stubProfObjs ghciObjFiles = hObjs ++ map (libTargetDir ) cObjs ++ stubObjs dynamicObjectFiles = hSharedObjs ++ map (libTargetDir ) cSharedObjs ++ stubSharedObjs -- After the relocation lib is created we invoke ghc -shared -- with the dependencies spelled out as -package arguments -- and ghc invokes the linker with the proper library paths ghcSharedLinkArgs = mempty { ghcOptShared = toFlag True, ghcOptDynLinkMode = toFlag GhcDynamicOnly, ghcOptInputFiles = toNubListR dynamicObjectFiles, ghcOptOutputFile = toFlag sharedLibFilePath, -- For dynamic libs, Mac OS/X needs to know the install location -- at build time. This only applies to GHC < 7.8 - see the -- discussion in #1660. ghcOptDylibName = if (hostOS == OSX && ghcVersion < Version [7,8] []) then toFlag sharedLibInstallPath else mempty, ghcOptPackageKey = toFlag (pkgKey lbi), ghcOptNoAutoLinkPackages = toFlag True, ghcOptPackageDBs = withPackageDB lbi, ghcOptPackages = toNubListR $ Internal.mkGhcOptPackages clbi , ghcOptLinkLibs = toNubListR $ extraLibs libBi, ghcOptLinkLibPath = toNubListR $ extraLibDirs libBi, ghcOptLinkFrameworks = toNubListR $ PD.frameworks libBi, ghcOptRPaths = rpaths } info verbosity (show (ghcOptPackages ghcSharedLinkArgs)) whenVanillaLib False $ do Ar.createArLibArchive verbosity lbi vanillaLibFilePath staticObjectFiles whenProfLib $ do Ar.createArLibArchive verbosity lbi profileLibFilePath profObjectFiles whenGHCiLib $ do (ldProg, _) <- requireProgram verbosity ldProgram (withPrograms lbi) Ld.combineObjectFiles verbosity ldProg ghciLibFilePath ghciObjFiles whenSharedLib False $ runGhcProg ghcSharedLinkArgs -- | Start a REPL without loading any source files. startInterpreter :: Verbosity -> ProgramConfiguration -> Compiler -> PackageDBStack -> IO () startInterpreter verbosity conf comp packageDBs = do let replOpts = mempty { ghcOptMode = toFlag GhcModeInteractive, ghcOptPackageDBs = packageDBs } checkPackageDbStack packageDBs (ghcProg, _) <- requireProgram verbosity ghcProgram conf runGHC verbosity ghcProg comp replOpts -- | Build an executable with GHC. -- buildExe, replExe :: Verbosity -> Cabal.Flag (Maybe Int) -> PackageDescription -> LocalBuildInfo -> Executable -> ComponentLocalBuildInfo -> IO () buildExe = buildOrReplExe False replExe = buildOrReplExe True buildOrReplExe :: Bool -> Verbosity -> Cabal.Flag (Maybe Int) -> PackageDescription -> LocalBuildInfo -> Executable -> ComponentLocalBuildInfo -> IO () buildOrReplExe forRepl verbosity numJobs _pkg_descr lbi exe@Executable { exeName = exeName', modulePath = modPath } clbi = do (ghcProg, _) <- requireProgram verbosity ghcProgram (withPrograms lbi) let comp = compiler lbi implInfo = getImplInfo comp runGhcProg = runGHC verbosity ghcProg comp exeBi <- hackThreadedFlag verbosity comp (withProfExe lbi) (buildInfo exe) -- exeNameReal, the name that GHC really uses (with .exe on Windows) let exeNameReal = exeName' <.> (if takeExtension exeName' /= ('.':exeExtension) then exeExtension else "") let targetDir = (buildDir lbi) exeName' let exeDir = targetDir (exeName' ++ "-tmp") createDirectoryIfMissingVerbose verbosity True targetDir createDirectoryIfMissingVerbose verbosity True exeDir -- TODO: do we need to put hs-boot files into place for mutually recursive -- modules? FIX: what about exeName.hi-boot? -- Determine if program coverage should be enabled and if so, what -- '-hpcdir' should be. let isCoverageEnabled = fromFlag $ configCoverage $ configFlags lbi distPref = fromFlag $ configDistPref $ configFlags lbi hpcdir way | isCoverageEnabled = toFlag $ Hpc.mixDir distPref way exeName' | otherwise = mempty -- build executables srcMainFile <- findFile (exeDir : hsSourceDirs exeBi) modPath rpaths <- getRPaths lbi clbi let isGhcDynamic = isDynamic comp dynamicTooSupported = supportsDynamicToo comp isHaskellMain = elem (takeExtension srcMainFile) [".hs", ".lhs"] cSrcs = cSources exeBi ++ [srcMainFile | not isHaskellMain] cObjs = map (`replaceExtension` objExtension) cSrcs baseOpts = (componentGhcOptions verbosity lbi exeBi clbi exeDir) `mappend` mempty { ghcOptMode = toFlag GhcModeMake, ghcOptInputFiles = toNubListR [ srcMainFile | isHaskellMain], ghcOptInputModules = toNubListR [ m | not isHaskellMain, m <- exeModules exe] } staticOpts = baseOpts `mappend` mempty { ghcOptDynLinkMode = toFlag GhcStaticOnly, ghcOptHPCDir = hpcdir Hpc.Vanilla } profOpts = baseOpts `mappend` mempty { ghcOptProfilingMode = toFlag True, ghcOptHiSuffix = toFlag "p_hi", ghcOptObjSuffix = toFlag "p_o", ghcOptExtra = toNubListR $ hcProfOptions GHC exeBi, ghcOptHPCDir = hpcdir Hpc.Prof } dynOpts = baseOpts `mappend` mempty { ghcOptDynLinkMode = toFlag GhcDynamicOnly, ghcOptHiSuffix = toFlag "dyn_hi", ghcOptObjSuffix = toFlag "dyn_o", ghcOptExtra = toNubListR $ hcSharedOptions GHC exeBi, ghcOptHPCDir = hpcdir Hpc.Dyn } dynTooOpts = staticOpts `mappend` mempty { ghcOptDynLinkMode = toFlag GhcStaticAndDynamic, ghcOptDynHiSuffix = toFlag "dyn_hi", ghcOptDynObjSuffix = toFlag "dyn_o", ghcOptHPCDir = hpcdir Hpc.Dyn } linkerOpts = mempty { ghcOptLinkOptions = toNubListR $ PD.ldOptions exeBi, ghcOptLinkLibs = toNubListR $ extraLibs exeBi, ghcOptLinkLibPath = toNubListR $ extraLibDirs exeBi, ghcOptLinkFrameworks = toNubListR $ PD.frameworks exeBi, ghcOptInputFiles = toNubListR [exeDir x | x <- cObjs], ghcOptRPaths = rpaths } replOpts = baseOpts { ghcOptExtra = overNubListR Internal.filterGhciFlags (ghcOptExtra baseOpts) } -- For a normal compile we do separate invocations of ghc for -- compiling as for linking. But for repl we have to do just -- the one invocation, so that one has to include all the -- linker stuff too, like -l flags and any .o files from C -- files etc. `mappend` linkerOpts `mappend` mempty { ghcOptMode = toFlag GhcModeInteractive, ghcOptOptimisation = toFlag GhcNoOptimisation } commonOpts | withProfExe lbi = profOpts | withDynExe lbi = dynOpts | otherwise = staticOpts compileOpts | useDynToo = dynTooOpts | otherwise = commonOpts withStaticExe = (not $ withProfExe lbi) && (not $ withDynExe lbi) -- For building exe's that use TH with -prof or -dynamic we actually have -- to build twice, once without -prof/-dynamic and then again with -- -prof/-dynamic. This is because the code that TH needs to run at -- compile time needs to be the vanilla ABI so it can be loaded up and run -- by the compiler. -- With dynamic-by-default GHC the TH object files loaded at compile-time -- need to be .dyn_o instead of .o. doingTH = EnableExtension TemplateHaskell `elem` allExtensions exeBi -- Should we use -dynamic-too instead of compiling twice? useDynToo = dynamicTooSupported && isGhcDynamic && doingTH && withStaticExe && null (hcSharedOptions GHC exeBi) compileTHOpts | isGhcDynamic = dynOpts | otherwise = staticOpts compileForTH | forRepl = False | useDynToo = False | isGhcDynamic = doingTH && (withProfExe lbi || withStaticExe) | otherwise = doingTH && (withProfExe lbi || withDynExe lbi) linkOpts = commonOpts `mappend` linkerOpts `mappend` mempty { ghcOptLinkNoHsMain = toFlag (not isHaskellMain) } -- Build static/dynamic object files for TH, if needed. when compileForTH $ runGhcProg compileTHOpts { ghcOptNoLink = toFlag True , ghcOptNumJobs = numJobs } unless forRepl $ runGhcProg compileOpts { ghcOptNoLink = toFlag True , ghcOptNumJobs = numJobs } -- build any C sources unless (null cSrcs) $ do info verbosity "Building C Sources..." sequence_ [ do let opts = (Internal.componentCcGhcOptions verbosity implInfo lbi exeBi clbi exeDir filename) `mappend` mempty { ghcOptDynLinkMode = toFlag (if withDynExe lbi then GhcDynamicOnly else GhcStaticOnly), ghcOptProfilingMode = toFlag (withProfExe lbi) } odir = fromFlag (ghcOptObjDir opts) createDirectoryIfMissingVerbose verbosity True odir needsRecomp <- checkNeedsRecompilation filename opts when needsRecomp $ runGhcProg opts | filename <- cSrcs ] -- TODO: problem here is we need the .c files built first, so we can load them -- with ghci, but .c files can depend on .h files generated by ghc by ffi -- exports. when forRepl $ runGhcProg replOpts -- link: unless forRepl $ do info verbosity "Linking..." runGhcProg linkOpts { ghcOptOutputFile = toFlag (targetDir exeNameReal) } -- | Returns True if the modification date of the given source file is newer than -- the object file we last compiled for it, or if no object file exists yet. checkNeedsRecompilation :: FilePath -> GhcOptions -> IO Bool checkNeedsRecompilation filename opts = filename `moreRecentFile` oname where oname = getObjectFileName filename opts -- | Finds the object file name of the given source file getObjectFileName :: FilePath -> GhcOptions -> FilePath getObjectFileName filename opts = oname where odir = fromFlag (ghcOptObjDir opts) oext = fromFlagOrDefault "o" (ghcOptObjSuffix opts) oname = odir replaceExtension filename oext -- | Calculate the RPATHs for the component we are building. -- -- Calculates relative RPATHs when 'relocatable' is set. getRPaths :: LocalBuildInfo -> ComponentLocalBuildInfo -- ^ Component we are building -> IO (NubListR FilePath) getRPaths lbi clbi | supportRPaths hostOS = do libraryPaths <- depLibraryPaths False (relocatable lbi) lbi clbi let hostPref = case hostOS of OSX -> "@loader_path" _ -> "$ORIGIN" relPath p = if isRelative p then hostPref p else p rpaths = toNubListR (map relPath libraryPaths) return rpaths where (Platform _ hostOS) = hostPlatform lbi -- The list of RPath-supported operating systems below reflects the -- platforms on which Cabal's RPATH handling is tested. It does _NOT_ -- reflect whether the OS supports RPATH. -- E.g. when this comment was written, the *BSD operating systems were -- untested with regards to Cabal RPATH handling, and were hence set to -- 'False', while those operating systems themselves do support RPATH. supportRPaths Linux   = True supportRPaths Windows = False supportRPaths OSX   = True supportRPaths FreeBSD   = False supportRPaths OpenBSD   = False supportRPaths NetBSD   = False supportRPaths DragonFly = False supportRPaths Solaris = False supportRPaths AIX = False supportRPaths HPUX = False supportRPaths IRIX = False supportRPaths HaLVM = False supportRPaths IOS = False supportRPaths Ghcjs = False supportRPaths (OtherOS _) = False -- Do _not_ add a default case so that we get a warning here when a new OS -- is added. getRPaths _ _ = return mempty -- | Filter the "-threaded" flag when profiling as it does not -- work with ghc-6.8 and older. hackThreadedFlag :: Verbosity -> Compiler -> Bool -> BuildInfo -> IO BuildInfo hackThreadedFlag verbosity comp prof bi | not mustFilterThreaded = return bi | otherwise = do warn verbosity $ "The ghc flag '-threaded' is not compatible with " ++ "profiling in ghc-6.8 and older. It will be disabled." return bi { options = filterHcOptions (/= "-threaded") (options bi) } where mustFilterThreaded = prof && compilerVersion comp < Version [6, 10] [] && "-threaded" `elem` hcOptions GHC bi filterHcOptions p hcoptss = [ (hc, if hc == GHC then filter p opts else opts) | (hc, opts) <- hcoptss ] -- | Extracts a String representing a hash of the ABI of a built -- library. It can fail if the library has not yet been built. -- libAbiHash :: Verbosity -> PackageDescription -> LocalBuildInfo -> Library -> ComponentLocalBuildInfo -> IO String libAbiHash verbosity _pkg_descr lbi lib clbi = do libBi <- hackThreadedFlag verbosity (compiler lbi) (withProfLib lbi) (libBuildInfo lib) let comp = compiler lbi vanillaArgs = (componentGhcOptions verbosity lbi libBi clbi (buildDir lbi)) `mappend` mempty { ghcOptMode = toFlag GhcModeAbiHash, ghcOptPackageKey = toFlag (pkgKey lbi), ghcOptInputModules = toNubListR $ exposedModules lib } sharedArgs = vanillaArgs `mappend` mempty { ghcOptDynLinkMode = toFlag GhcDynamicOnly, ghcOptFPic = toFlag True, ghcOptHiSuffix = toFlag "dyn_hi", ghcOptObjSuffix = toFlag "dyn_o", ghcOptExtra = toNubListR $ hcSharedOptions GHC libBi } profArgs = vanillaArgs `mappend` mempty { ghcOptProfilingMode = toFlag True, ghcOptHiSuffix = toFlag "p_hi", ghcOptObjSuffix = toFlag "p_o", ghcOptExtra = toNubListR $ hcProfOptions GHC libBi } ghcArgs = if withVanillaLib lbi then vanillaArgs else if withSharedLib lbi then sharedArgs else if withProfLib lbi then profArgs else error "libAbiHash: Can't find an enabled library way" -- (ghcProg, _) <- requireProgram verbosity ghcProgram (withPrograms lbi) hash <- getProgramInvocationOutput verbosity (ghcInvocation ghcProg comp ghcArgs) return (takeWhile (not . isSpace) hash) componentGhcOptions :: Verbosity -> LocalBuildInfo -> BuildInfo -> ComponentLocalBuildInfo -> FilePath -> GhcOptions componentGhcOptions = Internal.componentGhcOptions -- ----------------------------------------------------------------------------- -- Installing -- |Install executables for GHC. installExe :: Verbosity -> LocalBuildInfo -> InstallDirs FilePath -- ^Where to copy the files to -> FilePath -- ^Build location -> (FilePath, FilePath) -- ^Executable (prefix,suffix) -> PackageDescription -> Executable -> IO () installExe verbosity lbi installDirs buildPref (progprefix, progsuffix) _pkg exe = do let binDir = bindir installDirs createDirectoryIfMissingVerbose verbosity True binDir let exeFileName = exeName exe <.> exeExtension fixedExeBaseName = progprefix ++ exeName exe ++ progsuffix installBinary dest = do installExecutableFile verbosity (buildPref exeName exe exeFileName) (dest <.> exeExtension) when (stripExes lbi) $ Strip.stripExe verbosity (hostPlatform lbi) (withPrograms lbi) (dest <.> exeExtension) installBinary (binDir fixedExeBaseName) -- |Install for ghc, .hi, .a and, if --with-ghci given, .o installLib :: Verbosity -> LocalBuildInfo -> FilePath -- ^install location -> FilePath -- ^install location for dynamic libraries -> FilePath -- ^Build location -> PackageDescription -> Library -> ComponentLocalBuildInfo -> IO () installLib verbosity lbi targetDir dynlibTargetDir builtDir _pkg lib clbi = do -- copy .hi files over: whenVanilla $ copyModuleFiles "hi" whenProf $ copyModuleFiles "p_hi" whenShared $ copyModuleFiles "dyn_hi" -- copy the built library files over: whenVanilla $ mapM_ (installOrdinary builtDir targetDir) vanillaLibNames whenProf $ mapM_ (installOrdinary builtDir targetDir) profileLibNames whenGHCi $ mapM_ (installOrdinary builtDir targetDir) ghciLibNames whenShared $ mapM_ (installShared builtDir dynlibTargetDir) sharedLibNames where install isShared srcDir dstDir name = do let src = srcDir name dst = dstDir name createDirectoryIfMissingVerbose verbosity True dstDir if isShared then do when (stripLibs lbi) $ Strip.stripLib verbosity (hostPlatform lbi) (withPrograms lbi) src installExecutableFile verbosity src dst else installOrdinaryFile verbosity src dst installOrdinary = install False installShared = install True copyModuleFiles ext = findModuleFiles [builtDir] [ext] (libModules lib) >>= installOrdinaryFiles verbosity targetDir cid = compilerId (compiler lbi) libNames = componentLibraries clbi vanillaLibNames = map mkLibName libNames profileLibNames = map mkProfLibName libNames ghciLibNames = map Internal.mkGHCiLibName libNames sharedLibNames = map (mkSharedLibName cid) libNames hasLib = not $ null (libModules lib) && null (cSources (libBuildInfo lib)) whenVanilla = when (hasLib && withVanillaLib lbi) whenProf = when (hasLib && withProfLib lbi) whenGHCi = when (hasLib && withGHCiLib lbi) whenShared = when (hasLib && withSharedLib lbi) -- ----------------------------------------------------------------------------- -- Registering hcPkgInfo :: ProgramConfiguration -> HcPkg.HcPkgInfo hcPkgInfo conf = HcPkg.HcPkgInfo { HcPkg.hcPkgProgram = ghcPkgProg , HcPkg.noPkgDbStack = v < [6,9] , HcPkg.noVerboseFlag = v < [6,11] , HcPkg.flagPackageConf = v < [7,5] , HcPkg.useSingleFileDb = v < [7,9] } where v = versionBranch ver Just ghcPkgProg = lookupProgram ghcPkgProgram conf Just ver = programVersion ghcPkgProg registerPackage :: Verbosity -> InstalledPackageInfo -> PackageDescription -> LocalBuildInfo -> Bool -> PackageDBStack -> IO () registerPackage verbosity installedPkgInfo _pkg lbi _inplace packageDbs = HcPkg.reregister (hcPkgInfo $ withPrograms lbi) verbosity packageDbs (Right installedPkgInfo) pkgRoot :: Verbosity -> LocalBuildInfo -> PackageDB -> IO FilePath pkgRoot verbosity lbi = pkgRoot' where pkgRoot' GlobalPackageDB = let Just ghcProg = lookupProgram ghcProgram (withPrograms lbi) in fmap takeDirectory (getGlobalPackageDB verbosity ghcProg) pkgRoot' UserPackageDB = do appDir <- getAppUserDataDirectory "ghc" let ver = compilerVersion (compiler lbi) subdir = System.Info.arch ++ '-':System.Info.os ++ '-':showVersion ver rootDir = appDir subdir -- We must create the root directory for the user package database if it -- does not yet exists. Otherwise '${pkgroot}' will resolve to a -- directory at the time of 'ghc-pkg register', and registration will -- fail. createDirectoryIfMissing True rootDir return rootDir pkgRoot' (SpecificPackageDB fp) = return (takeDirectory fp) -- ----------------------------------------------------------------------------- -- Utils isDynamic :: Compiler -> Bool isDynamic = Internal.ghcLookupProperty "GHC Dynamic" supportsDynamicToo :: Compiler -> Bool supportsDynamicToo = Internal.ghcLookupProperty "Support dynamic-too" Cabal-1.22.5.0/Distribution/Simple/GHCJS.hs0000644000000000000000000012061112627136220016233 0ustar0000000000000000{-# LANGUAGE CPP #-} module Distribution.Simple.GHCJS ( configure, getInstalledPackages, getPackageDBContents, buildLib, buildExe, replLib, replExe, startInterpreter, installLib, installExe, libAbiHash, hcPkgInfo, registerPackage, componentGhcOptions, getLibDir, isDynamic, getGlobalPackageDB, runCmd ) where import Distribution.Simple.GHC.ImplInfo ( getImplInfo, ghcjsVersionImplInfo ) import qualified Distribution.Simple.GHC.Internal as Internal import Distribution.PackageDescription as PD ( PackageDescription(..), BuildInfo(..), Executable(..) , Library(..), libModules, exeModules , hcOptions, hcProfOptions, hcSharedOptions , allExtensions ) import Distribution.InstalledPackageInfo ( InstalledPackageInfo ) import qualified Distribution.InstalledPackageInfo as InstalledPackageInfo ( InstalledPackageInfo_(..) ) import Distribution.Simple.PackageIndex ( InstalledPackageIndex ) import qualified Distribution.Simple.PackageIndex as PackageIndex import Distribution.Simple.LocalBuildInfo ( LocalBuildInfo(..), ComponentLocalBuildInfo(..) , LibraryName(..) ) import qualified Distribution.Simple.Hpc as Hpc import Distribution.Simple.InstallDirs hiding ( absoluteInstallDirs ) import Distribution.Simple.BuildPaths import Distribution.Simple.Utils import Distribution.Simple.Program ( Program(..), ConfiguredProgram(..), ProgramConfiguration , ProgramSearchPath , rawSystemProgramConf , rawSystemProgramStdout, rawSystemProgramStdoutConf , getProgramInvocationOutput , requireProgramVersion, requireProgram , userMaybeSpecifyPath, programPath , lookupProgram, addKnownPrograms , ghcjsProgram, ghcjsPkgProgram, c2hsProgram, hsc2hsProgram , ldProgram, haddockProgram, stripProgram ) import qualified Distribution.Simple.Program.HcPkg as HcPkg import qualified Distribution.Simple.Program.Ar as Ar import qualified Distribution.Simple.Program.Ld as Ld import qualified Distribution.Simple.Program.Strip as Strip import Distribution.Simple.Program.GHC import Distribution.Simple.Setup ( toFlag, fromFlag, configCoverage, configDistPref ) import qualified Distribution.Simple.Setup as Cabal ( Flag(..) ) import Distribution.Simple.Compiler ( CompilerFlavor(..), CompilerId(..), Compiler(..) , PackageDB(..), PackageDBStack, AbiTag(..) ) import Distribution.Version ( Version(..), anyVersion, orLaterVersion ) import Distribution.System ( Platform(..) ) import Distribution.Verbosity import Distribution.Utils.NubList ( overNubListR, toNubListR ) import Distribution.Text ( display ) import Language.Haskell.Extension ( Extension(..) , KnownExtension(..)) import Control.Monad ( unless, when ) import Data.Char ( isSpace ) import qualified Data.Map as M ( fromList ) #if __GLASGOW_HASKELL__ < 710 import Data.Monoid ( Monoid(..) ) #endif import System.Directory ( doesFileExist ) import System.FilePath ( (), (<.>), takeExtension, takeDirectory, replaceExtension, splitExtension ) configure :: Verbosity -> Maybe FilePath -> Maybe FilePath -> ProgramConfiguration -> IO (Compiler, Maybe Platform, ProgramConfiguration) configure verbosity hcPath hcPkgPath conf0 = do (ghcjsProg, ghcjsVersion, conf1) <- requireProgramVersion verbosity ghcjsProgram (orLaterVersion (Version [0,1] [])) (userMaybeSpecifyPath "ghcjs" hcPath conf0) Just ghcjsGhcVersion <- findGhcjsGhcVersion verbosity (programPath ghcjsProg) let implInfo = ghcjsVersionImplInfo ghcjsVersion ghcjsGhcVersion -- This is slightly tricky, we have to configure ghcjs first, then we use the -- location of ghcjs to help find ghcjs-pkg in the case that the user did not -- specify the location of ghc-pkg directly: (ghcjsPkgProg, ghcjsPkgVersion, conf2) <- requireProgramVersion verbosity ghcjsPkgProgram { programFindLocation = guessGhcjsPkgFromGhcjsPath ghcjsProg } anyVersion (userMaybeSpecifyPath "ghcjs-pkg" hcPkgPath conf1) Just ghcjsPkgGhcjsVersion <- findGhcjsPkgGhcjsVersion verbosity (programPath ghcjsPkgProg) when (ghcjsVersion /= ghcjsPkgGhcjsVersion) $ die $ "Version mismatch between ghcjs and ghcjs-pkg: " ++ programPath ghcjsProg ++ " is version " ++ display ghcjsVersion ++ " " ++ programPath ghcjsPkgProg ++ " is version " ++ display ghcjsPkgGhcjsVersion when (ghcjsGhcVersion /= ghcjsPkgVersion) $ die $ "Version mismatch between ghcjs and ghcjs-pkg: " ++ programPath ghcjsProg ++ " was built with GHC version " ++ display ghcjsGhcVersion ++ " " ++ programPath ghcjsPkgProg ++ " was built with GHC version " ++ display ghcjsPkgVersion -- be sure to use our versions of hsc2hs, c2hs, haddock and ghc let hsc2hsProgram' = hsc2hsProgram { programFindLocation = guessHsc2hsFromGhcjsPath ghcjsProg } c2hsProgram' = c2hsProgram { programFindLocation = guessC2hsFromGhcjsPath ghcjsProg } haddockProgram' = haddockProgram { programFindLocation = guessHaddockFromGhcjsPath ghcjsProg } conf3 = addKnownPrograms [ hsc2hsProgram', c2hsProgram', haddockProgram' ] conf2 languages <- Internal.getLanguages verbosity implInfo ghcjsProg extensions <- Internal.getExtensions verbosity implInfo ghcjsProg ghcInfo <- Internal.getGhcInfo verbosity implInfo ghcjsProg let ghcInfoMap = M.fromList ghcInfo let comp = Compiler { compilerId = CompilerId GHCJS ghcjsVersion, compilerAbiTag = AbiTag $ "ghc" ++ intercalate "_" (map show . versionBranch $ ghcjsGhcVersion), compilerCompat = [CompilerId GHC ghcjsGhcVersion], compilerLanguages = languages, compilerExtensions = extensions, compilerProperties = ghcInfoMap } compPlatform = Internal.targetPlatform ghcInfo -- configure gcc and ld let conf4 = if ghcjsNativeToo comp then Internal.configureToolchain implInfo ghcjsProg ghcInfoMap conf3 else conf3 return (comp, compPlatform, conf4) ghcjsNativeToo :: Compiler -> Bool ghcjsNativeToo = Internal.ghcLookupProperty "Native Too" guessGhcjsPkgFromGhcjsPath :: ConfiguredProgram -> Verbosity -> ProgramSearchPath -> IO (Maybe FilePath) guessGhcjsPkgFromGhcjsPath = guessToolFromGhcjsPath ghcjsPkgProgram guessHsc2hsFromGhcjsPath :: ConfiguredProgram -> Verbosity -> ProgramSearchPath -> IO (Maybe FilePath) guessHsc2hsFromGhcjsPath = guessToolFromGhcjsPath hsc2hsProgram guessC2hsFromGhcjsPath :: ConfiguredProgram -> Verbosity -> ProgramSearchPath -> IO (Maybe FilePath) guessC2hsFromGhcjsPath = guessToolFromGhcjsPath c2hsProgram guessHaddockFromGhcjsPath :: ConfiguredProgram -> Verbosity -> ProgramSearchPath -> IO (Maybe FilePath) guessHaddockFromGhcjsPath = guessToolFromGhcjsPath haddockProgram guessToolFromGhcjsPath :: Program -> ConfiguredProgram -> Verbosity -> ProgramSearchPath -> IO (Maybe FilePath) guessToolFromGhcjsPath tool ghcjsProg verbosity searchpath = do let toolname = programName tool path = programPath ghcjsProg dir = takeDirectory path versionSuffix = takeVersionSuffix (dropExeExtension path) guessNormal = dir toolname <.> exeExtension guessGhcjsVersioned = dir (toolname ++ "-ghcjs" ++ versionSuffix) <.> exeExtension guessGhcjs = dir (toolname ++ "-ghcjs") <.> exeExtension guessVersioned = dir (toolname ++ versionSuffix) <.> exeExtension guesses | null versionSuffix = [guessGhcjs, guessNormal] | otherwise = [guessGhcjsVersioned, guessGhcjs, guessVersioned, guessNormal] info verbosity $ "looking for tool " ++ toolname ++ " near compiler in " ++ dir exists <- mapM doesFileExist guesses case [ file | (file, True) <- zip guesses exists ] of -- If we can't find it near ghc, fall back to the usual -- method. [] -> programFindLocation tool verbosity searchpath (fp:_) -> do info verbosity $ "found " ++ toolname ++ " in " ++ fp return (Just fp) where takeVersionSuffix :: FilePath -> String takeVersionSuffix = reverse . takeWhile (`elem ` "0123456789.-") . reverse dropExeExtension :: FilePath -> FilePath dropExeExtension filepath = case splitExtension filepath of (filepath', extension) | extension == exeExtension -> filepath' | otherwise -> filepath -- | Given a single package DB, return all installed packages. getPackageDBContents :: Verbosity -> PackageDB -> ProgramConfiguration -> IO InstalledPackageIndex getPackageDBContents verbosity packagedb conf = do pkgss <- getInstalledPackages' verbosity [packagedb] conf toPackageIndex verbosity pkgss conf -- | Given a package DB stack, return all installed packages. getInstalledPackages :: Verbosity -> PackageDBStack -> ProgramConfiguration -> IO InstalledPackageIndex getInstalledPackages verbosity packagedbs conf = do checkPackageDbEnvVar checkPackageDbStack packagedbs pkgss <- getInstalledPackages' verbosity packagedbs conf index <- toPackageIndex verbosity pkgss conf return $! index toPackageIndex :: Verbosity -> [(PackageDB, [InstalledPackageInfo])] -> ProgramConfiguration -> IO InstalledPackageIndex toPackageIndex verbosity pkgss conf = do -- On Windows, various fields have $topdir/foo rather than full -- paths. We need to substitute the right value in so that when -- we, for example, call gcc, we have proper paths to give it. topDir <- getLibDir' verbosity ghcjsProg let indices = [ PackageIndex.fromList (map (Internal.substTopDir topDir) pkgs) | (_, pkgs) <- pkgss ] return $! (mconcat indices) where Just ghcjsProg = lookupProgram ghcjsProgram conf checkPackageDbEnvVar :: IO () checkPackageDbEnvVar = Internal.checkPackageDbEnvVar "GHCJS" "GHCJS_PACKAGE_PATH" checkPackageDbStack :: PackageDBStack -> IO () checkPackageDbStack (GlobalPackageDB:rest) | GlobalPackageDB `notElem` rest = return () checkPackageDbStack rest | GlobalPackageDB `notElem` rest = die $ "With current ghc versions the global package db is always used " ++ "and must be listed first. This ghc limitation may be lifted in " ++ "future, see http://hackage.haskell.org/trac/ghc/ticket/5977" checkPackageDbStack _ = die $ "If the global package db is specified, it must be " ++ "specified first and cannot be specified multiple times" getInstalledPackages' :: Verbosity -> [PackageDB] -> ProgramConfiguration -> IO [(PackageDB, [InstalledPackageInfo])] getInstalledPackages' verbosity packagedbs conf = sequence [ do pkgs <- HcPkg.dump (hcPkgInfo conf) verbosity packagedb return (packagedb, pkgs) | packagedb <- packagedbs ] getLibDir :: Verbosity -> LocalBuildInfo -> IO FilePath getLibDir verbosity lbi = (reverse . dropWhile isSpace . reverse) `fmap` rawSystemProgramStdoutConf verbosity ghcjsProgram (withPrograms lbi) ["--print-libdir"] getLibDir' :: Verbosity -> ConfiguredProgram -> IO FilePath getLibDir' verbosity ghcjsProg = (reverse . dropWhile isSpace . reverse) `fmap` rawSystemProgramStdout verbosity ghcjsProg ["--print-libdir"] -- | Return the 'FilePath' to the global GHC package database. getGlobalPackageDB :: Verbosity -> ConfiguredProgram -> IO FilePath getGlobalPackageDB verbosity ghcjsProg = (reverse . dropWhile isSpace . reverse) `fmap` rawSystemProgramStdout verbosity ghcjsProg ["--print-global-package-db"] toJSLibName :: String -> String toJSLibName lib | takeExtension lib `elem` [".dll",".dylib",".so"] = replaceExtension lib "js_so" | takeExtension lib == ".a" = replaceExtension lib "js_a" | otherwise = lib <.> "js_a" buildLib, replLib :: Verbosity -> Cabal.Flag (Maybe Int) -> PackageDescription -> LocalBuildInfo -> Library -> ComponentLocalBuildInfo -> IO () buildLib = buildOrReplLib False replLib = buildOrReplLib True buildOrReplLib :: Bool -> Verbosity -> Cabal.Flag (Maybe Int) -> PackageDescription -> LocalBuildInfo -> Library -> ComponentLocalBuildInfo -> IO () buildOrReplLib forRepl verbosity numJobs _pkg_descr lbi lib clbi = do libName <- case componentLibraries clbi of [libName] -> return libName [] -> die "No library name found when building library" _ -> die "Multiple library names found when building library" let libTargetDir = buildDir lbi whenVanillaLib forceVanilla = when (not forRepl && (forceVanilla || withVanillaLib lbi)) whenProfLib = when (not forRepl && withProfLib lbi) whenSharedLib forceShared = when (not forRepl && (forceShared || withSharedLib lbi)) whenGHCiLib = when (not forRepl && withGHCiLib lbi && withVanillaLib lbi) ifReplLib = when forRepl comp = compiler lbi implInfo = getImplInfo comp hole_insts = map (\(k,(p,n)) -> (k,(InstalledPackageInfo.packageKey p,n))) (instantiatedWith lbi) nativeToo = ghcjsNativeToo comp (ghcjsProg, _) <- requireProgram verbosity ghcjsProgram (withPrograms lbi) let runGhcjsProg = runGHC verbosity ghcjsProg comp libBi = libBuildInfo lib isGhcjsDynamic = isDynamic comp dynamicTooSupported = supportsDynamicToo comp doingTH = EnableExtension TemplateHaskell `elem` allExtensions libBi forceVanillaLib = doingTH && not isGhcjsDynamic forceSharedLib = doingTH && isGhcjsDynamic -- TH always needs default libs, even when building for profiling -- Determine if program coverage should be enabled and if so, what -- '-hpcdir' should be. let isCoverageEnabled = fromFlag $ configCoverage $ configFlags lbi -- Component name. Not 'libName' because that has the "HS" prefix -- that GHC gives Haskell libraries. cname = display $ PD.package $ localPkgDescr lbi distPref = fromFlag $ configDistPref $ configFlags lbi hpcdir way | isCoverageEnabled = toFlag $ Hpc.mixDir distPref way cname | otherwise = mempty createDirectoryIfMissingVerbose verbosity True libTargetDir -- TODO: do we need to put hs-boot files into place for mutually recursive -- modules? let cObjs = map (`replaceExtension` objExtension) (cSources libBi) jsSrcs = jsSources libBi baseOpts = componentGhcOptions verbosity lbi libBi clbi libTargetDir linkJsLibOpts = mempty { ghcOptExtra = toNubListR $ [ "-link-js-lib" , (\(LibraryName l) -> l) libName , "-js-lib-outputdir", libTargetDir ] ++ concatMap (\x -> ["-js-lib-src",x]) jsSrcs } vanillaOptsNoJsLib = baseOpts `mappend` mempty { ghcOptMode = toFlag GhcModeMake, ghcOptNumJobs = numJobs, ghcOptPackageKey = toFlag (pkgKey lbi), ghcOptSigOf = hole_insts, ghcOptInputModules = toNubListR $ libModules lib, ghcOptHPCDir = hpcdir Hpc.Vanilla } vanillaOpts = vanillaOptsNoJsLib `mappend` linkJsLibOpts profOpts = adjustExts "p_hi" "p_o" vanillaOpts `mappend` mempty { ghcOptProfilingMode = toFlag True, ghcOptExtra = toNubListR $ ghcjsProfOptions libBi, ghcOptHPCDir = hpcdir Hpc.Prof } sharedOpts = adjustExts "dyn_hi" "dyn_o" vanillaOpts `mappend` mempty { ghcOptDynLinkMode = toFlag GhcDynamicOnly, ghcOptFPic = toFlag True, ghcOptExtra = toNubListR $ ghcjsSharedOptions libBi, ghcOptHPCDir = hpcdir Hpc.Dyn } linkerOpts = mempty { ghcOptLinkOptions = toNubListR $ PD.ldOptions libBi, ghcOptLinkLibs = toNubListR $ extraLibs libBi, ghcOptLinkLibPath = toNubListR $ extraLibDirs libBi, ghcOptLinkFrameworks = toNubListR $ PD.frameworks libBi, ghcOptInputFiles = toNubListR $ [libTargetDir x | x <- cObjs] ++ jsSrcs } replOpts = vanillaOptsNoJsLib { ghcOptExtra = overNubListR Internal.filterGhciFlags (ghcOptExtra vanillaOpts), ghcOptNumJobs = mempty } `mappend` linkerOpts `mappend` mempty { ghcOptMode = toFlag GhcModeInteractive, ghcOptOptimisation = toFlag GhcNoOptimisation } vanillaSharedOpts = vanillaOpts `mappend` mempty { ghcOptDynLinkMode = toFlag GhcStaticAndDynamic, ghcOptDynHiSuffix = toFlag "dyn_hi", ghcOptDynObjSuffix = toFlag "dyn_o", ghcOptHPCDir = hpcdir Hpc.Dyn } unless (forRepl || (null (libModules lib) && null jsSrcs && null cObjs)) $ do let vanilla = whenVanillaLib forceVanillaLib (runGhcjsProg vanillaOpts) shared = whenSharedLib forceSharedLib (runGhcjsProg sharedOpts) useDynToo = dynamicTooSupported && (forceVanillaLib || withVanillaLib lbi) && (forceSharedLib || withSharedLib lbi) && null (ghcjsSharedOptions libBi) if useDynToo then do runGhcjsProg vanillaSharedOpts case (hpcdir Hpc.Dyn, hpcdir Hpc.Vanilla) of (Cabal.Flag dynDir, Cabal.Flag vanillaDir) -> do -- When the vanilla and shared library builds are done -- in one pass, only one set of HPC module interfaces -- are generated. This set should suffice for both -- static and dynamically linked executables. We copy -- the modules interfaces so they are available under -- both ways. copyDirectoryRecursive verbosity dynDir vanillaDir _ -> return () else if isGhcjsDynamic then do shared; vanilla else do vanilla; shared whenProfLib (runGhcjsProg profOpts) -- build any C sources unless (null (cSources libBi) || not nativeToo) $ do info verbosity "Building C Sources..." sequence_ [ do let vanillaCcOpts = (Internal.componentCcGhcOptions verbosity implInfo lbi libBi clbi libTargetDir filename) profCcOpts = vanillaCcOpts `mappend` mempty { ghcOptProfilingMode = toFlag True, ghcOptObjSuffix = toFlag "p_o" } sharedCcOpts = vanillaCcOpts `mappend` mempty { ghcOptFPic = toFlag True, ghcOptDynLinkMode = toFlag GhcDynamicOnly, ghcOptObjSuffix = toFlag "dyn_o" } odir = fromFlag (ghcOptObjDir vanillaCcOpts) createDirectoryIfMissingVerbose verbosity True odir runGhcjsProg vanillaCcOpts whenSharedLib forceSharedLib (runGhcjsProg sharedCcOpts) whenProfLib (runGhcjsProg profCcOpts) | filename <- cSources libBi] -- TODO: problem here is we need the .c files built first, so we can load them -- with ghci, but .c files can depend on .h files generated by ghc by ffi -- exports. unless (null (libModules lib)) $ ifReplLib (runGhcjsProg replOpts) -- link: when (nativeToo && not forRepl) $ do info verbosity "Linking..." let cProfObjs = map (`replaceExtension` ("p_" ++ objExtension)) (cSources libBi) cSharedObjs = map (`replaceExtension` ("dyn_" ++ objExtension)) (cSources libBi) cid = compilerId (compiler lbi) vanillaLibFilePath = libTargetDir mkLibName libName profileLibFilePath = libTargetDir mkProfLibName libName sharedLibFilePath = libTargetDir mkSharedLibName cid libName ghciLibFilePath = libTargetDir Internal.mkGHCiLibName libName hObjs <- Internal.getHaskellObjects implInfo lib lbi libTargetDir objExtension True hProfObjs <- if (withProfLib lbi) then Internal.getHaskellObjects implInfo lib lbi libTargetDir ("p_" ++ objExtension) True else return [] hSharedObjs <- if (withSharedLib lbi) then Internal.getHaskellObjects implInfo lib lbi libTargetDir ("dyn_" ++ objExtension) False else return [] unless (null hObjs && null cObjs) $ do let staticObjectFiles = hObjs ++ map (libTargetDir ) cObjs profObjectFiles = hProfObjs ++ map (libTargetDir ) cProfObjs ghciObjFiles = hObjs ++ map (libTargetDir ) cObjs dynamicObjectFiles = hSharedObjs ++ map (libTargetDir ) cSharedObjs -- After the relocation lib is created we invoke ghc -shared -- with the dependencies spelled out as -package arguments -- and ghc invokes the linker with the proper library paths ghcSharedLinkArgs = mempty { ghcOptShared = toFlag True, ghcOptDynLinkMode = toFlag GhcDynamicOnly, ghcOptInputFiles = toNubListR dynamicObjectFiles, ghcOptOutputFile = toFlag sharedLibFilePath, ghcOptPackageKey = toFlag (pkgKey lbi), ghcOptNoAutoLinkPackages = toFlag True, ghcOptPackageDBs = withPackageDB lbi, ghcOptPackages = toNubListR $ Internal.mkGhcOptPackages clbi, ghcOptLinkLibs = toNubListR $ extraLibs libBi, ghcOptLinkLibPath = toNubListR $ extraLibDirs libBi } whenVanillaLib False $ do Ar.createArLibArchive verbosity lbi vanillaLibFilePath staticObjectFiles whenProfLib $ do Ar.createArLibArchive verbosity lbi profileLibFilePath profObjectFiles whenGHCiLib $ do (ldProg, _) <- requireProgram verbosity ldProgram (withPrograms lbi) Ld.combineObjectFiles verbosity ldProg ghciLibFilePath ghciObjFiles whenSharedLib False $ runGhcjsProg ghcSharedLinkArgs -- | Start a REPL without loading any source files. startInterpreter :: Verbosity -> ProgramConfiguration -> Compiler -> PackageDBStack -> IO () startInterpreter verbosity conf comp packageDBs = do let replOpts = mempty { ghcOptMode = toFlag GhcModeInteractive, ghcOptPackageDBs = packageDBs } checkPackageDbStack packageDBs (ghcjsProg, _) <- requireProgram verbosity ghcjsProgram conf runGHC verbosity ghcjsProg comp replOpts buildExe, replExe :: Verbosity -> Cabal.Flag (Maybe Int) -> PackageDescription -> LocalBuildInfo -> Executable -> ComponentLocalBuildInfo -> IO () buildExe = buildOrReplExe False replExe = buildOrReplExe True buildOrReplExe :: Bool -> Verbosity -> Cabal.Flag (Maybe Int) -> PackageDescription -> LocalBuildInfo -> Executable -> ComponentLocalBuildInfo -> IO () buildOrReplExe forRepl verbosity numJobs _pkg_descr lbi exe@Executable { exeName = exeName', modulePath = modPath } clbi = do (ghcjsProg, _) <- requireProgram verbosity ghcjsProgram (withPrograms lbi) let comp = compiler lbi implInfo = getImplInfo comp runGhcjsProg = runGHC verbosity ghcjsProg comp exeBi = buildInfo exe -- exeNameReal, the name that GHC really uses (with .exe on Windows) let exeNameReal = exeName' <.> (if takeExtension exeName' /= ('.':exeExtension) then exeExtension else "") let targetDir = (buildDir lbi) exeName' let exeDir = targetDir (exeName' ++ "-tmp") createDirectoryIfMissingVerbose verbosity True targetDir createDirectoryIfMissingVerbose verbosity True exeDir -- TODO: do we need to put hs-boot files into place for mutually recursive -- modules? FIX: what about exeName.hi-boot? -- Determine if program coverage should be enabled and if so, what -- '-hpcdir' should be. let isCoverageEnabled = fromFlag $ configCoverage $ configFlags lbi distPref = fromFlag $ configDistPref $ configFlags lbi hpcdir way | isCoverageEnabled = toFlag $ Hpc.mixDir distPref way exeName' | otherwise = mempty -- build executables srcMainFile <- findFile (exeDir : hsSourceDirs exeBi) modPath let isGhcjsDynamic = isDynamic comp dynamicTooSupported = supportsDynamicToo comp buildRunner = case clbi of ExeComponentLocalBuildInfo {} -> False _ -> True isHaskellMain = elem (takeExtension srcMainFile) [".hs", ".lhs"] jsSrcs = jsSources exeBi cSrcs = cSources exeBi ++ [srcMainFile | not isHaskellMain] cObjs = map (`replaceExtension` objExtension) cSrcs nativeToo = ghcjsNativeToo comp baseOpts = (componentGhcOptions verbosity lbi exeBi clbi exeDir) `mappend` mempty { ghcOptMode = toFlag GhcModeMake, ghcOptInputFiles = toNubListR $ [ srcMainFile | isHaskellMain], ghcOptInputModules = toNubListR $ [ m | not isHaskellMain, m <- exeModules exe], ghcOptExtra = if buildRunner then toNubListR ["-build-runner"] else mempty } staticOpts = baseOpts `mappend` mempty { ghcOptDynLinkMode = toFlag GhcStaticOnly, ghcOptHPCDir = hpcdir Hpc.Vanilla } profOpts = adjustExts "p_hi" "p_o" baseOpts `mappend` mempty { ghcOptProfilingMode = toFlag True, ghcOptExtra = toNubListR $ ghcjsProfOptions exeBi, ghcOptHPCDir = hpcdir Hpc.Prof } dynOpts = adjustExts "dyn_hi" "dyn_o" baseOpts `mappend` mempty { ghcOptDynLinkMode = toFlag GhcDynamicOnly, ghcOptExtra = toNubListR $ ghcjsSharedOptions exeBi, ghcOptHPCDir = hpcdir Hpc.Dyn } dynTooOpts = adjustExts "dyn_hi" "dyn_o" staticOpts `mappend` mempty { ghcOptDynLinkMode = toFlag GhcStaticAndDynamic, ghcOptHPCDir = hpcdir Hpc.Dyn } linkerOpts = mempty { ghcOptLinkOptions = toNubListR $ PD.ldOptions exeBi, ghcOptLinkLibs = toNubListR $ extraLibs exeBi, ghcOptLinkLibPath = toNubListR $ extraLibDirs exeBi, ghcOptLinkFrameworks = toNubListR $ PD.frameworks exeBi, ghcOptInputFiles = toNubListR $ [exeDir x | x <- cObjs] ++ jsSrcs } replOpts = baseOpts { ghcOptExtra = overNubListR Internal.filterGhciFlags (ghcOptExtra baseOpts) } -- For a normal compile we do separate invocations of ghc for -- compiling as for linking. But for repl we have to do just -- the one invocation, so that one has to include all the -- linker stuff too, like -l flags and any .o files from C -- files etc. `mappend` linkerOpts `mappend` mempty { ghcOptMode = toFlag GhcModeInteractive, ghcOptOptimisation = toFlag GhcNoOptimisation } commonOpts | withProfExe lbi = profOpts | withDynExe lbi = dynOpts | otherwise = staticOpts compileOpts | useDynToo = dynTooOpts | otherwise = commonOpts withStaticExe = (not $ withProfExe lbi) && (not $ withDynExe lbi) -- For building exe's that use TH with -prof or -dynamic we actually have -- to build twice, once without -prof/-dynamic and then again with -- -prof/-dynamic. This is because the code that TH needs to run at -- compile time needs to be the vanilla ABI so it can be loaded up and run -- by the compiler. -- With dynamic-by-default GHC the TH object files loaded at compile-time -- need to be .dyn_o instead of .o. doingTH = EnableExtension TemplateHaskell `elem` allExtensions exeBi -- Should we use -dynamic-too instead of compiling twice? useDynToo = dynamicTooSupported && isGhcjsDynamic && doingTH && withStaticExe && null (ghcjsSharedOptions exeBi) compileTHOpts | isGhcjsDynamic = dynOpts | otherwise = staticOpts compileForTH | forRepl = False | useDynToo = False | isGhcjsDynamic = doingTH && (withProfExe lbi || withStaticExe) | otherwise = doingTH && (withProfExe lbi || withDynExe lbi) linkOpts = commonOpts `mappend` linkerOpts `mappend` mempty { ghcOptLinkNoHsMain = toFlag (not isHaskellMain) } -- Build static/dynamic object files for TH, if needed. when compileForTH $ runGhcjsProg compileTHOpts { ghcOptNoLink = toFlag True , ghcOptNumJobs = numJobs } unless forRepl $ runGhcjsProg compileOpts { ghcOptNoLink = toFlag True , ghcOptNumJobs = numJobs } -- build any C sources unless (null cSrcs || not nativeToo) $ do info verbosity "Building C Sources..." sequence_ [ do let opts = (Internal.componentCcGhcOptions verbosity implInfo lbi exeBi clbi exeDir filename) `mappend` mempty { ghcOptDynLinkMode = toFlag (if withDynExe lbi then GhcDynamicOnly else GhcStaticOnly), ghcOptProfilingMode = toFlag (withProfExe lbi) } odir = fromFlag (ghcOptObjDir opts) createDirectoryIfMissingVerbose verbosity True odir runGhcjsProg opts | filename <- cSrcs ] -- TODO: problem here is we need the .c files built first, so we can load them -- with ghci, but .c files can depend on .h files generated by ghc by ffi -- exports. when forRepl $ runGhcjsProg replOpts -- link: unless forRepl $ do info verbosity "Linking..." runGhcjsProg linkOpts { ghcOptOutputFile = toFlag (targetDir exeNameReal) } -- |Install for ghc, .hi, .a and, if --with-ghci given, .o installLib :: Verbosity -> LocalBuildInfo -> FilePath -- ^install location -> FilePath -- ^install location for dynamic libraries -> FilePath -- ^Build location -> PackageDescription -> Library -> ComponentLocalBuildInfo -> IO () installLib verbosity lbi targetDir dynlibTargetDir builtDir _pkg lib clbi = do whenVanilla $ copyModuleFiles "js_hi" whenProf $ copyModuleFiles "js_p_hi" whenShared $ copyModuleFiles "js_dyn_hi" whenVanilla $ mapM_ (installOrdinary builtDir targetDir . toJSLibName) vanillaLibNames whenProf $ mapM_ (installOrdinary builtDir targetDir . toJSLibName) profileLibNames whenShared $ mapM_ (installShared builtDir dynlibTargetDir . toJSLibName) sharedLibNames when (ghcjsNativeToo $ compiler lbi) $ do -- copy .hi files over: whenVanilla $ copyModuleFiles "hi" whenProf $ copyModuleFiles "p_hi" whenShared $ copyModuleFiles "dyn_hi" -- copy the built library files over: whenVanilla $ mapM_ (installOrdinary builtDir targetDir) vanillaLibNames whenProf $ mapM_ (installOrdinary builtDir targetDir) profileLibNames whenGHCi $ mapM_ (installOrdinary builtDir targetDir) ghciLibNames whenShared $ mapM_ (installShared builtDir dynlibTargetDir) sharedLibNames where install isShared srcDir dstDir name = do let src = srcDir name dst = dstDir name createDirectoryIfMissingVerbose verbosity True dstDir if isShared then do when (stripLibs lbi) $ Strip.stripLib verbosity (hostPlatform lbi) (withPrograms lbi) src installExecutableFile verbosity src dst else installOrdinaryFile verbosity src dst installOrdinary = install False installShared = install True copyModuleFiles ext = findModuleFiles [builtDir] [ext] (libModules lib) >>= installOrdinaryFiles verbosity targetDir cid = compilerId (compiler lbi) libNames = componentLibraries clbi vanillaLibNames = map mkLibName libNames profileLibNames = map mkProfLibName libNames ghciLibNames = map Internal.mkGHCiLibName libNames sharedLibNames = map (mkSharedLibName cid) libNames hasLib = not $ null (libModules lib) && null (cSources (libBuildInfo lib)) whenVanilla = when (hasLib && withVanillaLib lbi) whenProf = when (hasLib && withProfLib lbi) whenGHCi = when (hasLib && withGHCiLib lbi) whenShared = when (hasLib && withSharedLib lbi) installExe :: Verbosity -> LocalBuildInfo -> InstallDirs FilePath -- ^Where to copy the files to -> FilePath -- ^Build location -> (FilePath, FilePath) -- ^Executable (prefix,suffix) -> PackageDescription -> Executable -> IO () installExe verbosity lbi installDirs buildPref (progprefix, progsuffix) _pkg exe = do let binDir = bindir installDirs createDirectoryIfMissingVerbose verbosity True binDir let exeFileName = exeName exe fixedExeBaseName = progprefix ++ exeName exe ++ progsuffix installBinary dest = do rawSystemProgramConf verbosity ghcjsProgram (withPrograms lbi) $ [ "--install-executable" , buildPref exeName exe exeFileName , "-o", dest ] ++ case (stripExes lbi, lookupProgram stripProgram $ withPrograms lbi) of (True, Just strip) -> ["-strip-program", programPath strip] _ -> [] installBinary (binDir fixedExeBaseName) libAbiHash :: Verbosity -> PackageDescription -> LocalBuildInfo -> Library -> ComponentLocalBuildInfo -> IO String libAbiHash verbosity _pkg_descr lbi lib clbi = do let libBi = libBuildInfo lib comp = compiler lbi vanillaArgs = (componentGhcOptions verbosity lbi libBi clbi (buildDir lbi)) `mappend` mempty { ghcOptMode = toFlag GhcModeAbiHash, ghcOptPackageKey = toFlag (pkgKey lbi), ghcOptInputModules = toNubListR $ exposedModules lib } profArgs = adjustExts "js_p_hi" "js_p_o" vanillaArgs `mappend` mempty { ghcOptProfilingMode = toFlag True, ghcOptExtra = toNubListR (ghcjsProfOptions libBi) } ghcArgs = if withVanillaLib lbi then vanillaArgs else if withProfLib lbi then profArgs else error "libAbiHash: Can't find an enabled library way" -- (ghcjsProg, _) <- requireProgram verbosity ghcjsProgram (withPrograms lbi) getProgramInvocationOutput verbosity (ghcInvocation ghcjsProg comp ghcArgs) adjustExts :: String -> String -> GhcOptions -> GhcOptions adjustExts hiSuf objSuf opts = opts `mappend` mempty { ghcOptHiSuffix = toFlag hiSuf, ghcOptObjSuffix = toFlag objSuf } registerPackage :: Verbosity -> InstalledPackageInfo -> PackageDescription -> LocalBuildInfo -> Bool -> PackageDBStack -> IO () registerPackage verbosity installedPkgInfo _pkg lbi _inplace packageDbs = HcPkg.reregister (hcPkgInfo $ withPrograms lbi) verbosity packageDbs (Right installedPkgInfo) componentGhcOptions :: Verbosity -> LocalBuildInfo -> BuildInfo -> ComponentLocalBuildInfo -> FilePath -> GhcOptions componentGhcOptions verbosity lbi bi clbi odir = let opts = Internal.componentGhcOptions verbosity lbi bi clbi odir in opts { ghcOptExtra = ghcOptExtra opts `mappend` toNubListR (hcOptions GHCJS bi) } ghcjsProfOptions :: BuildInfo -> [String] ghcjsProfOptions bi = hcProfOptions GHC bi `mappend` hcProfOptions GHCJS bi ghcjsSharedOptions :: BuildInfo -> [String] ghcjsSharedOptions bi = hcSharedOptions GHC bi `mappend` hcSharedOptions GHCJS bi isDynamic :: Compiler -> Bool isDynamic = Internal.ghcLookupProperty "GHC Dynamic" supportsDynamicToo :: Compiler -> Bool supportsDynamicToo = Internal.ghcLookupProperty "Support dynamic-too" findGhcjsGhcVersion :: Verbosity -> FilePath -> IO (Maybe Version) findGhcjsGhcVersion verbosity pgm = findProgramVersion "--numeric-ghc-version" id verbosity pgm findGhcjsPkgGhcjsVersion :: Verbosity -> FilePath -> IO (Maybe Version) findGhcjsPkgGhcjsVersion verbosity pgm = findProgramVersion "--numeric-ghcjs-version" id verbosity pgm -- ----------------------------------------------------------------------------- -- Registering hcPkgInfo :: ProgramConfiguration -> HcPkg.HcPkgInfo hcPkgInfo conf = HcPkg.HcPkgInfo { HcPkg.hcPkgProgram = ghcjsPkgProg , HcPkg.noPkgDbStack = False , HcPkg.noVerboseFlag = False , HcPkg.flagPackageConf = False , HcPkg.useSingleFileDb = v < [7,9] } where v = versionBranch ver Just ghcjsPkgProg = lookupProgram ghcjsPkgProgram conf Just ver = programVersion ghcjsPkgProg -- | Get the JavaScript file name and command and arguments to run a -- program compiled by GHCJS -- the exe should be the base program name without exe extension runCmd :: ProgramConfiguration -> FilePath -> (FilePath, FilePath, [String]) runCmd conf exe = ( script , programPath ghcjsProg , programDefaultArgs ghcjsProg ++ programOverrideArgs ghcjsProg ++ ["--run"] ) where script = exe <.> "jsexe" "all" <.> "js" Just ghcjsProg = lookupProgram ghcjsProgram conf Cabal-1.22.5.0/Distribution/Simple/Haddock.hs0000644000000000000000000010105612627136220016734 0ustar0000000000000000----------------------------------------------------------------------------- -- | -- Module : Distribution.Simple.Haddock -- Copyright : Isaac Jones 2003-2005 -- License : BSD3 -- -- Maintainer : cabal-devel@haskell.org -- Portability : portable -- -- This module deals with the @haddock@ and @hscolour@ commands. -- It uses information about installed packages (from @ghc-pkg@) to find the -- locations of documentation for dependent packages, so it can create links. -- -- The @hscolour@ support allows generating HTML versions of the original -- source, with coloured syntax highlighting. module Distribution.Simple.Haddock ( haddock, hscolour, haddockPackagePaths ) where import qualified Distribution.Simple.GHC as GHC import qualified Distribution.Simple.GHCJS as GHCJS -- local import Distribution.Package ( PackageIdentifier(..) , Package(..) , PackageName(..), packageName ) import qualified Distribution.ModuleName as ModuleName import Distribution.PackageDescription as PD ( PackageDescription(..), BuildInfo(..), usedExtensions , hcSharedOptions , Library(..), hasLibs, Executable(..) , TestSuite(..), TestSuiteInterface(..) , Benchmark(..), BenchmarkInterface(..) ) import Distribution.Simple.Compiler ( Compiler, compilerInfo, CompilerFlavor(..) , compilerFlavor, compilerCompatVersion ) import Distribution.Simple.Program.GHC ( GhcOptions(..), GhcDynLinkMode(..), renderGhcOptions ) import Distribution.Simple.Program ( ConfiguredProgram(..), lookupProgramVersion, requireProgramVersion , rawSystemProgram, rawSystemProgramStdout , hscolourProgram, haddockProgram ) import Distribution.Simple.PreProcess ( PPSuffixHandler, preprocessComponent) import Distribution.Simple.Setup ( defaultHscolourFlags , Flag(..), toFlag, flagToMaybe, flagToList, fromFlag , HaddockFlags(..), HscolourFlags(..) ) import Distribution.Simple.Build (initialBuildSteps) import Distribution.Simple.InstallDirs ( InstallDirs(..) , PathTemplateEnv, PathTemplate, PathTemplateVariable(..) , toPathTemplate, fromPathTemplate , substPathTemplate, initialPathTemplateEnv ) import Distribution.Simple.LocalBuildInfo ( LocalBuildInfo(..), Component(..), ComponentLocalBuildInfo(..) , withAllComponentsInBuildOrder ) import Distribution.Simple.BuildPaths ( haddockName, hscolourPref, autogenModulesDir) import Distribution.Simple.PackageIndex (dependencyClosure) import qualified Distribution.Simple.PackageIndex as PackageIndex import qualified Distribution.InstalledPackageInfo as InstalledPackageInfo ( InstalledPackageInfo_(..) ) import Distribution.InstalledPackageInfo ( InstalledPackageInfo ) import Distribution.Simple.Utils ( die, copyFileTo, warn, notice, intercalate, setupMessage , createDirectoryIfMissingVerbose , TempFileOptions(..), defaultTempFileOptions , withTempFileEx, copyFileVerbose , withTempDirectoryEx, matchFileGlob , findFileWithExtension, findFile ) import Distribution.Text ( display, simpleParse ) import Distribution.Utils.NubList ( toNubListR ) import Distribution.Verbosity import Language.Haskell.Extension import Control.Monad ( when, forM_ ) import Data.Either ( rights ) import Data.Monoid import Data.Maybe ( fromMaybe, listToMaybe ) import System.Directory (doesFileExist) import System.FilePath ( (), (<.>) , normalise, splitPath, joinPath, isAbsolute ) import System.IO (hClose, hPutStrLn, hSetEncoding, utf8) import Distribution.Version -- ------------------------------------------------------------------------------ -- Types -- | A record that represents the arguments to the haddock executable, a product -- monoid. data HaddockArgs = HaddockArgs { argInterfaceFile :: Flag FilePath, -- ^ Path to the interface file, relative to argOutputDir, required. argPackageName :: Flag PackageIdentifier, -- ^ Package name, required. argHideModules :: (All,[ModuleName.ModuleName]), -- ^ (Hide modules ?, modules to hide) argIgnoreExports :: Any, -- ^ Ignore export lists in modules? argLinkSource :: Flag (Template,Template,Template), -- ^ (Template for modules, template for symbols, template for lines). argCssFile :: Flag FilePath, -- ^ Optional custom CSS file. argContents :: Flag String, -- ^ Optional URL to contents page. argVerbose :: Any, argOutput :: Flag [Output], -- ^ HTML or Hoogle doc or both? Required. argInterfaces :: [(FilePath, Maybe String)], -- ^ [(Interface file, URL to the HTML docs for links)]. argOutputDir :: Directory, -- ^ Where to generate the documentation. argTitle :: Flag String, -- ^ Page title, required. argPrologue :: Flag String, -- ^ Prologue text, required. argGhcOptions :: Flag (GhcOptions, Version), -- ^ Additional flags to pass to GHC. argGhcLibDir :: Flag FilePath, -- ^ To find the correct GHC, required. argTargets :: [FilePath] -- ^ Modules to process. } -- | The FilePath of a directory, it's a monoid under '()'. newtype Directory = Dir { unDir' :: FilePath } deriving (Read,Show,Eq,Ord) unDir :: Directory -> FilePath unDir = joinPath . filter (\p -> p /="./" && p /= ".") . splitPath . unDir' type Template = String data Output = Html | Hoogle -- ------------------------------------------------------------------------------ -- Haddock support haddock :: PackageDescription -> LocalBuildInfo -> [PPSuffixHandler] -> HaddockFlags -> IO () haddock pkg_descr _ _ haddockFlags | not (hasLibs pkg_descr) && not (fromFlag $ haddockExecutables haddockFlags) && not (fromFlag $ haddockTestSuites haddockFlags) && not (fromFlag $ haddockBenchmarks haddockFlags) = warn (fromFlag $ haddockVerbosity haddockFlags) $ "No documentation was generated as this package does not contain " ++ "a library. Perhaps you want to use the --executables, --tests or" ++ " --benchmarks flags." haddock pkg_descr lbi suffixes flags = do setupMessage verbosity "Running Haddock for" (packageId pkg_descr) (confHaddock, version, _) <- requireProgramVersion verbosity haddockProgram (orLaterVersion (Version [2,0] [])) (withPrograms lbi) -- various sanity checks when ( flag haddockHoogle && version < Version [2,2] []) $ die "haddock 2.0 and 2.1 do not support the --hoogle flag." haddockGhcVersionStr <- rawSystemProgramStdout verbosity confHaddock ["--ghc-version"] case (simpleParse haddockGhcVersionStr, compilerCompatVersion GHC comp) of (Nothing, _) -> die "Could not get GHC version from Haddock" (_, Nothing) -> die "Could not get GHC version from compiler" (Just haddockGhcVersion, Just ghcVersion) | haddockGhcVersion == ghcVersion -> return () | otherwise -> die $ "Haddock's internal GHC version must match the configured " ++ "GHC version.\n" ++ "The GHC version is " ++ display ghcVersion ++ " but " ++ "haddock is using GHC version " ++ display haddockGhcVersion -- the tools match the requests, we can proceed initialBuildSteps (flag haddockDistPref) pkg_descr lbi verbosity when (flag haddockHscolour) $ hscolour' (warn verbosity) pkg_descr lbi suffixes (defaultHscolourFlags `mappend` haddockToHscolour flags) libdirArgs <- getGhcLibDir verbosity lbi let commonArgs = mconcat [ libdirArgs , fromFlags (haddockTemplateEnv lbi (packageId pkg_descr)) flags , fromPackageDescription pkg_descr ] let pre c = preprocessComponent pkg_descr c lbi False verbosity suffixes withAllComponentsInBuildOrder pkg_descr lbi $ \component clbi -> do pre component let doExe com = case (compToExe com) of Just exe -> do withTempDirectoryEx verbosity tmpFileOpts (buildDir lbi) "tmp" $ \tmp -> do exeArgs <- fromExecutable verbosity tmp lbi exe clbi htmlTemplate version let exeArgs' = commonArgs `mappend` exeArgs runHaddock verbosity tmpFileOpts comp confHaddock exeArgs' Nothing -> do warn (fromFlag $ haddockVerbosity flags) "Unsupported component, skipping..." return () case component of CLib lib -> do withTempDirectoryEx verbosity tmpFileOpts (buildDir lbi) "tmp" $ \tmp -> do libArgs <- fromLibrary verbosity tmp lbi lib clbi htmlTemplate version let libArgs' = commonArgs `mappend` libArgs runHaddock verbosity tmpFileOpts comp confHaddock libArgs' CExe _ -> when (flag haddockExecutables) $ doExe component CTest _ -> when (flag haddockTestSuites) $ doExe component CBench _ -> when (flag haddockBenchmarks) $ doExe component forM_ (extraDocFiles pkg_descr) $ \ fpath -> do files <- matchFileGlob fpath forM_ files $ copyFileTo verbosity (unDir $ argOutputDir commonArgs) where verbosity = flag haddockVerbosity keepTempFiles = flag haddockKeepTempFiles comp = compiler lbi tmpFileOpts = defaultTempFileOptions { optKeepTempFiles = keepTempFiles } flag f = fromFlag $ f flags htmlTemplate = fmap toPathTemplate . flagToMaybe . haddockHtmlLocation $ flags -- ------------------------------------------------------------------------------ -- Contributions to HaddockArgs. fromFlags :: PathTemplateEnv -> HaddockFlags -> HaddockArgs fromFlags env flags = mempty { argHideModules = (maybe mempty (All . not) $ flagToMaybe (haddockInternal flags), mempty), argLinkSource = if fromFlag (haddockHscolour flags) then Flag ("src/%{MODULE/./-}.html" ,"src/%{MODULE/./-}.html#%{NAME}" ,"src/%{MODULE/./-}.html#line-%{LINE}") else NoFlag, argCssFile = haddockCss flags, argContents = fmap (fromPathTemplate . substPathTemplate env) (haddockContents flags), argVerbose = maybe mempty (Any . (>= deafening)) . flagToMaybe $ haddockVerbosity flags, argOutput = Flag $ case [ Html | Flag True <- [haddockHtml flags] ] ++ [ Hoogle | Flag True <- [haddockHoogle flags] ] of [] -> [ Html ] os -> os, argOutputDir = maybe mempty Dir . flagToMaybe $ haddockDistPref flags } fromPackageDescription :: PackageDescription -> HaddockArgs fromPackageDescription pkg_descr = mempty { argInterfaceFile = Flag $ haddockName pkg_descr, argPackageName = Flag $ packageId $ pkg_descr, argOutputDir = Dir $ "doc" "html" display (packageName pkg_descr), argPrologue = Flag $ if null desc then synopsis pkg_descr else desc, argTitle = Flag $ showPkg ++ subtitle } where desc = PD.description pkg_descr showPkg = display (packageId pkg_descr) subtitle | null (synopsis pkg_descr) = "" | otherwise = ": " ++ synopsis pkg_descr componentGhcOptions :: Verbosity -> LocalBuildInfo -> BuildInfo -> ComponentLocalBuildInfo -> FilePath -> GhcOptions componentGhcOptions verbosity lbi bi clbi odir = let f = case compilerFlavor (compiler lbi) of GHC -> GHC.componentGhcOptions GHCJS -> GHCJS.componentGhcOptions _ -> error $ "Distribution.Simple.Haddock.componentGhcOptions:" ++ "haddock only supports GHC and GHCJS" in f verbosity lbi bi clbi odir fromLibrary :: Verbosity -> FilePath -> LocalBuildInfo -> Library -> ComponentLocalBuildInfo -> Maybe PathTemplate -- ^ template for HTML location -> Version -> IO HaddockArgs fromLibrary verbosity tmp lbi lib clbi htmlTemplate haddockVersion = do inFiles <- map snd `fmap` getLibSourceFiles lbi lib ifaceArgs <- getInterfaces verbosity lbi clbi htmlTemplate let vanillaOpts = (componentGhcOptions normal lbi bi clbi (buildDir lbi)) { -- Noooooooooo!!!!!111 -- haddock stomps on our precious .hi -- and .o files. Workaround by telling -- haddock to write them elsewhere. ghcOptObjDir = toFlag tmp, ghcOptHiDir = toFlag tmp, ghcOptStubDir = toFlag tmp, ghcOptPackageKey = toFlag $ pkgKey lbi } `mappend` getGhcCppOpts haddockVersion bi sharedOpts = vanillaOpts { ghcOptDynLinkMode = toFlag GhcDynamicOnly, ghcOptFPic = toFlag True, ghcOptHiSuffix = toFlag "dyn_hi", ghcOptObjSuffix = toFlag "dyn_o", ghcOptExtra = toNubListR $ hcSharedOptions GHC bi } opts <- if withVanillaLib lbi then return vanillaOpts else if withSharedLib lbi then return sharedOpts else die $ "Must have vanilla or shared libraries " ++ "enabled in order to run haddock" ghcVersion <- maybe (die "Compiler has no GHC version") return (compilerCompatVersion GHC (compiler lbi)) return ifaceArgs { argHideModules = (mempty,otherModules $ bi), argGhcOptions = toFlag (opts, ghcVersion), argTargets = inFiles } where bi = libBuildInfo lib fromExecutable :: Verbosity -> FilePath -> LocalBuildInfo -> Executable -> ComponentLocalBuildInfo -> Maybe PathTemplate -- ^ template for HTML location -> Version -> IO HaddockArgs fromExecutable verbosity tmp lbi exe clbi htmlTemplate haddockVersion = do inFiles <- map snd `fmap` getExeSourceFiles lbi exe ifaceArgs <- getInterfaces verbosity lbi clbi htmlTemplate let vanillaOpts = (componentGhcOptions normal lbi bi clbi (buildDir lbi)) { -- Noooooooooo!!!!!111 -- haddock stomps on our precious .hi -- and .o files. Workaround by telling -- haddock to write them elsewhere. ghcOptObjDir = toFlag tmp, ghcOptHiDir = toFlag tmp, ghcOptStubDir = toFlag tmp } `mappend` getGhcCppOpts haddockVersion bi sharedOpts = vanillaOpts { ghcOptDynLinkMode = toFlag GhcDynamicOnly, ghcOptFPic = toFlag True, ghcOptHiSuffix = toFlag "dyn_hi", ghcOptObjSuffix = toFlag "dyn_o", ghcOptExtra = toNubListR $ hcSharedOptions GHC bi } opts <- if withVanillaLib lbi then return vanillaOpts else if withSharedLib lbi then return sharedOpts else die $ "Must have vanilla or shared libraries " ++ "enabled in order to run haddock" ghcVersion <- maybe (die "Compiler has no GHC version") return (compilerCompatVersion GHC (compiler lbi)) return ifaceArgs { argGhcOptions = toFlag (opts, ghcVersion), argOutputDir = Dir (exeName exe), argTitle = Flag (exeName exe), argTargets = inFiles } where bi = buildInfo exe compToExe :: Component -> Maybe Executable compToExe comp = case comp of CTest test@TestSuite { testInterface = TestSuiteExeV10 _ f } -> Just Executable { exeName = testName test, modulePath = f, buildInfo = testBuildInfo test } CBench bench@Benchmark { benchmarkInterface = BenchmarkExeV10 _ f } -> Just Executable { exeName = benchmarkName bench, modulePath = f, buildInfo = benchmarkBuildInfo bench } CExe exe -> Just exe _ -> Nothing getInterfaces :: Verbosity -> LocalBuildInfo -> ComponentLocalBuildInfo -> Maybe PathTemplate -- ^ template for HTML location -> IO HaddockArgs getInterfaces verbosity lbi clbi htmlTemplate = do (packageFlags, warnings) <- haddockPackageFlags lbi clbi htmlTemplate maybe (return ()) (warn verbosity) warnings return $ mempty { argInterfaces = packageFlags } getGhcCppOpts :: Version -> BuildInfo -> GhcOptions getGhcCppOpts haddockVersion bi = mempty { ghcOptExtensions = toNubListR [EnableExtension CPP | needsCpp], ghcOptCppOptions = toNubListR defines } where needsCpp = EnableExtension CPP `elem` usedExtensions bi defines = [haddockVersionMacro] haddockVersionMacro = "-D__HADDOCK_VERSION__=" ++ show (v1 * 1000 + v2 * 10 + v3) where [v1, v2, v3] = take 3 $ versionBranch haddockVersion ++ [0,0] getGhcLibDir :: Verbosity -> LocalBuildInfo -> IO HaddockArgs getGhcLibDir verbosity lbi = do l <- case compilerFlavor (compiler lbi) of GHC -> GHC.getLibDir verbosity lbi GHCJS -> GHCJS.getLibDir verbosity lbi _ -> error "haddock only supports GHC and GHCJS" return $ mempty { argGhcLibDir = Flag l } -- ------------------------------------------------------------------------------ -- | Call haddock with the specified arguments. runHaddock :: Verbosity -> TempFileOptions -> Compiler -> ConfiguredProgram -> HaddockArgs -> IO () runHaddock verbosity tmpFileOpts comp confHaddock args = do let haddockVersion = fromMaybe (error "unable to determine haddock version") (programVersion confHaddock) renderArgs verbosity tmpFileOpts haddockVersion comp args $ \(flags,result)-> do rawSystemProgram verbosity confHaddock flags notice verbosity $ "Documentation created: " ++ result renderArgs :: Verbosity -> TempFileOptions -> Version -> Compiler -> HaddockArgs -> (([String], FilePath) -> IO a) -> IO a renderArgs verbosity tmpFileOpts version comp args k = do let haddockSupportsUTF8 = version >= Version [2,14,4] [] haddockSupportsResponseFiles = version > Version [2,16,1] [] createDirectoryIfMissingVerbose verbosity True outputDir withTempFileEx tmpFileOpts outputDir "haddock-prologue.txt" $ \prologueFileName h -> do do when haddockSupportsUTF8 (hSetEncoding h utf8) hPutStrLn h $ fromFlag $ argPrologue args hClose h let pflag = "--prologue=" ++ prologueFileName renderedArgs = pflag : renderPureArgs version comp args if haddockSupportsResponseFiles then withTempFileEx tmpFileOpts outputDir "haddock-response.txt" $ \responseFileName hf -> do when haddockSupportsUTF8 (hSetEncoding hf utf8) mapM_ (hPutStrLn hf) renderedArgs hClose hf let respFile = "@" ++ responseFileName k ([respFile], result) else k (renderedArgs, result) where outputDir = (unDir $ argOutputDir args) result = intercalate ", " . map (\o -> outputDir case o of Html -> "index.html" Hoogle -> pkgstr <.> "txt") $ arg argOutput where pkgstr = display $ packageName pkgid pkgid = arg argPackageName arg f = fromFlag $ f args renderPureArgs :: Version -> Compiler -> HaddockArgs -> [String] renderPureArgs version comp args = concat [ (:[]) . (\f -> "--dump-interface="++ unDir (argOutputDir args) f) . fromFlag . argInterfaceFile $ args , if isVersion 2 16 then (\pkg -> [ "--package-name=" ++ display (pkgName pkg) , "--package-version="++display (pkgVersion pkg) ]) . fromFlag . argPackageName $ args else [] , (\(All b,xs) -> bool (map (("--hide=" ++). display) xs) [] b) . argHideModules $ args , bool ["--ignore-all-exports"] [] . getAny . argIgnoreExports $ args , maybe [] (\(m,e,l) -> ["--source-module=" ++ m ,"--source-entity=" ++ e] ++ if isVersion 2 14 then ["--source-entity-line=" ++ l] else [] ) . flagToMaybe . argLinkSource $ args , maybe [] ((:[]) . ("--css="++)) . flagToMaybe . argCssFile $ args , maybe [] ((:[]) . ("--use-contents="++)) . flagToMaybe . argContents $ args , bool [] [verbosityFlag] . getAny . argVerbose $ args , map (\o -> case o of Hoogle -> "--hoogle"; Html -> "--html") . fromFlag . argOutput $ args , renderInterfaces . argInterfaces $ args , (:[]) . ("--odir="++) . unDir . argOutputDir $ args , (:[]) . ("--title="++) . (bool (++" (internal documentation)") id (getAny $ argIgnoreExports args)) . fromFlag . argTitle $ args , [ "--optghc=" ++ opt | (opts, _ghcVer) <- flagToList (argGhcOptions args) , opt <- renderGhcOptions comp opts ] , maybe [] (\l -> ["-B"++l]) $ flagToMaybe (argGhcLibDir args) -- error if Nothing? , argTargets $ args ] where renderInterfaces = map (\(i,mh) -> "--read-interface=" ++ maybe "" (++",") mh ++ i) bool a b c = if c then a else b isVersion major minor = version >= Version [major,minor] [] verbosityFlag | isVersion 2 5 = "--verbosity=1" | otherwise = "--verbose" --------------------------------------------------------------------------------- -- | Given a list of 'InstalledPackageInfo's, return a list of interfaces and -- HTML paths, and an optional warning for packages with missing documentation. haddockPackagePaths :: [InstalledPackageInfo] -> Maybe (InstalledPackageInfo -> FilePath) -> IO ([(FilePath, Maybe FilePath)], Maybe String) haddockPackagePaths ipkgs mkHtmlPath = do interfaces <- sequence [ case interfaceAndHtmlPath ipkg of Nothing -> return (Left (packageId ipkg)) Just (interface, html) -> do exists <- doesFileExist interface if exists then return (Right (interface, html)) else return (Left pkgid) | ipkg <- ipkgs, let pkgid = packageId ipkg , pkgName pkgid `notElem` noHaddockWhitelist ] let missing = [ pkgid | Left pkgid <- interfaces ] warning = "The documentation for the following packages are not " ++ "installed. No links will be generated to these packages: " ++ intercalate ", " (map display missing) flags = rights interfaces return (flags, if null missing then Nothing else Just warning) where -- Don't warn about missing documentation for these packages. See #1231. noHaddockWhitelist = map PackageName [ "rts" ] -- Actually extract interface and HTML paths from an 'InstalledPackageInfo'. interfaceAndHtmlPath :: InstalledPackageInfo -> Maybe (FilePath, Maybe FilePath) interfaceAndHtmlPath pkg = do interface <- listToMaybe (InstalledPackageInfo.haddockInterfaces pkg) html <- case mkHtmlPath of Nothing -> fmap fixFileUrl (listToMaybe (InstalledPackageInfo.haddockHTMLs pkg)) Just mkPath -> Just (mkPath pkg) return (interface, if null html then Nothing else Just html) where -- The 'haddock-html' field in the hc-pkg output is often set as a -- native path, but we need it as a URL. See #1064. fixFileUrl f | isAbsolute f = "file://" ++ f | otherwise = f haddockPackageFlags :: LocalBuildInfo -> ComponentLocalBuildInfo -> Maybe PathTemplate -> IO ([(FilePath, Maybe FilePath)], Maybe String) haddockPackageFlags lbi clbi htmlTemplate = do let allPkgs = installedPkgs lbi directDeps = map fst (componentPackageDeps clbi) transitiveDeps <- case dependencyClosure allPkgs directDeps of Left x -> return x Right inf -> die $ "internal error when calculating transitive " ++ "package dependencies.\nDebug info: " ++ show inf haddockPackagePaths (PackageIndex.allPackages transitiveDeps) mkHtmlPath where mkHtmlPath = fmap expandTemplateVars htmlTemplate expandTemplateVars tmpl pkg = fromPathTemplate . substPathTemplate (env pkg) $ tmpl env pkg = haddockTemplateEnv lbi (packageId pkg) haddockTemplateEnv :: LocalBuildInfo -> PackageIdentifier -> PathTemplateEnv haddockTemplateEnv lbi pkg_id = (PrefixVar, prefix (installDirTemplates lbi)) : initialPathTemplateEnv pkg_id (pkgKey lbi) (compilerInfo (compiler lbi)) (hostPlatform lbi) -- ------------------------------------------------------------------------------ -- hscolour support. hscolour :: PackageDescription -> LocalBuildInfo -> [PPSuffixHandler] -> HscolourFlags -> IO () hscolour pkg_descr lbi suffixes flags = do -- we preprocess even if hscolour won't be found on the machine -- will this upset someone? initialBuildSteps distPref pkg_descr lbi verbosity hscolour' die pkg_descr lbi suffixes flags where verbosity = fromFlag (hscolourVerbosity flags) distPref = fromFlag $ hscolourDistPref flags hscolour' :: (String -> IO ()) -- ^ Called when the 'hscolour' exe is not found. -> PackageDescription -> LocalBuildInfo -> [PPSuffixHandler] -> HscolourFlags -> IO () hscolour' onNoHsColour pkg_descr lbi suffixes flags = either onNoHsColour (\(hscolourProg, _, _) -> go hscolourProg) =<< lookupProgramVersion verbosity hscolourProgram (orLaterVersion (Version [1,8] [])) (withPrograms lbi) where go :: ConfiguredProgram -> IO () go hscolourProg = do setupMessage verbosity "Running hscolour for" (packageId pkg_descr) createDirectoryIfMissingVerbose verbosity True $ hscolourPref distPref pkg_descr let pre c = preprocessComponent pkg_descr c lbi False verbosity suffixes withAllComponentsInBuildOrder pkg_descr lbi $ \comp _ -> do pre comp let doExe com = case (compToExe com) of Just exe -> do let outputDir = hscolourPref distPref pkg_descr exeName exe "src" runHsColour hscolourProg outputDir =<< getExeSourceFiles lbi exe Nothing -> do warn (fromFlag $ hscolourVerbosity flags) "Unsupported component, skipping..." return () case comp of CLib lib -> do let outputDir = hscolourPref distPref pkg_descr "src" runHsColour hscolourProg outputDir =<< getLibSourceFiles lbi lib CExe _ -> when (fromFlag (hscolourExecutables flags)) $ doExe comp CTest _ -> when (fromFlag (hscolourTestSuites flags)) $ doExe comp CBench _ -> when (fromFlag (hscolourBenchmarks flags)) $ doExe comp stylesheet = flagToMaybe (hscolourCSS flags) verbosity = fromFlag (hscolourVerbosity flags) distPref = fromFlag (hscolourDistPref flags) runHsColour prog outputDir moduleFiles = do createDirectoryIfMissingVerbose verbosity True outputDir case stylesheet of -- copy the CSS file Nothing | programVersion prog >= Just (Version [1,9] []) -> rawSystemProgram verbosity prog ["-print-css", "-o" ++ outputDir "hscolour.css"] | otherwise -> return () Just s -> copyFileVerbose verbosity s (outputDir "hscolour.css") forM_ moduleFiles $ \(m, inFile) -> rawSystemProgram verbosity prog ["-css", "-anchor", "-o" ++ outFile m, inFile] where outFile m = outputDir intercalate "-" (ModuleName.components m) <.> "html" haddockToHscolour :: HaddockFlags -> HscolourFlags haddockToHscolour flags = HscolourFlags { hscolourCSS = haddockHscolourCss flags, hscolourExecutables = haddockExecutables flags, hscolourTestSuites = haddockTestSuites flags, hscolourBenchmarks = haddockBenchmarks flags, hscolourVerbosity = haddockVerbosity flags, hscolourDistPref = haddockDistPref flags } --------------------------------------------------------------------------------- -- TODO these should be moved elsewhere. getLibSourceFiles :: LocalBuildInfo -> Library -> IO [(ModuleName.ModuleName, FilePath)] getLibSourceFiles lbi lib = getSourceFiles searchpaths modules where bi = libBuildInfo lib modules = PD.exposedModules lib ++ otherModules bi searchpaths = autogenModulesDir lbi : buildDir lbi : hsSourceDirs bi getExeSourceFiles :: LocalBuildInfo -> Executable -> IO [(ModuleName.ModuleName, FilePath)] getExeSourceFiles lbi exe = do moduleFiles <- getSourceFiles searchpaths modules srcMainPath <- findFile (hsSourceDirs bi) (modulePath exe) return ((ModuleName.main, srcMainPath) : moduleFiles) where bi = buildInfo exe modules = otherModules bi searchpaths = autogenModulesDir lbi : exeBuildDir lbi exe : hsSourceDirs bi getSourceFiles :: [FilePath] -> [ModuleName.ModuleName] -> IO [(ModuleName.ModuleName, FilePath)] getSourceFiles dirs modules = flip mapM modules $ \m -> fmap ((,) m) $ findFileWithExtension ["hs", "lhs"] dirs (ModuleName.toFilePath m) >>= maybe (notFound m) (return . normalise) where notFound module_ = die $ "can't find source for module " ++ display module_ -- | The directory where we put build results for an executable exeBuildDir :: LocalBuildInfo -> Executable -> FilePath exeBuildDir lbi exe = buildDir lbi exeName exe exeName exe ++ "-tmp" -- ------------------------------------------------------------------------------ -- Boilerplate Monoid instance. instance Monoid HaddockArgs where mempty = HaddockArgs { argInterfaceFile = mempty, argPackageName = mempty, argHideModules = mempty, argIgnoreExports = mempty, argLinkSource = mempty, argCssFile = mempty, argContents = mempty, argVerbose = mempty, argOutput = mempty, argInterfaces = mempty, argOutputDir = mempty, argTitle = mempty, argPrologue = mempty, argGhcOptions = mempty, argGhcLibDir = mempty, argTargets = mempty } mappend a b = HaddockArgs { argInterfaceFile = mult argInterfaceFile, argPackageName = mult argPackageName, argHideModules = mult argHideModules, argIgnoreExports = mult argIgnoreExports, argLinkSource = mult argLinkSource, argCssFile = mult argCssFile, argContents = mult argContents, argVerbose = mult argVerbose, argOutput = mult argOutput, argInterfaces = mult argInterfaces, argOutputDir = mult argOutputDir, argTitle = mult argTitle, argPrologue = mult argPrologue, argGhcOptions = mult argGhcOptions, argGhcLibDir = mult argGhcLibDir, argTargets = mult argTargets } where mult f = f a `mappend` f b instance Monoid Directory where mempty = Dir "." mappend (Dir m) (Dir n) = Dir $ m n Cabal-1.22.5.0/Distribution/Simple/HaskellSuite.hs0000644000000000000000000002023112627136220017767 0ustar0000000000000000{-# LANGUAGE CPP #-} module Distribution.Simple.HaskellSuite where import Control.Monad #if __GLASGOW_HASKELL__ < 710 import Control.Applicative #endif import Data.Maybe import Data.Version import qualified Data.Map as M (empty) import Distribution.Simple.Program import Distribution.Simple.Compiler as Compiler import Distribution.Simple.Utils import Distribution.Simple.BuildPaths import Distribution.Verbosity import Distribution.Text import Distribution.Package import Distribution.InstalledPackageInfo hiding (includeDirs) import Distribution.Simple.PackageIndex as PackageIndex import Distribution.PackageDescription import Distribution.Simple.LocalBuildInfo import Distribution.System (Platform) import Distribution.Compat.Exception import Language.Haskell.Extension import Distribution.Simple.Program.Builtin (haskellSuiteProgram, haskellSuitePkgProgram) configure :: Verbosity -> Maybe FilePath -> Maybe FilePath -> ProgramConfiguration -> IO (Compiler, Maybe Platform, ProgramConfiguration) configure verbosity mbHcPath hcPkgPath conf0 = do -- We have no idea how a haskell-suite tool is named, so we require at -- least some information from the user. hcPath <- let msg = "You have to provide name or path of a haskell-suite tool (-w PATH)" in maybe (die msg) return mbHcPath when (isJust hcPkgPath) $ warn verbosity "--with-hc-pkg option is ignored for haskell-suite" (comp, confdCompiler, conf1) <- configureCompiler hcPath conf0 -- Update our pkg tool. It uses the same executable as the compiler, but -- all command start with "pkg" (confdPkg, _) <- requireProgram verbosity haskellSuitePkgProgram conf1 let conf2 = updateProgram confdPkg { programLocation = programLocation confdCompiler , programDefaultArgs = ["pkg"] } conf1 return (comp, Nothing, conf2) where configureCompiler hcPath conf0' = do let haskellSuiteProgram' = haskellSuiteProgram { programFindLocation = \v _p -> findProgramLocation v hcPath } -- NB: cannot call requireProgram right away — it'd think that -- the program is already configured and won't reconfigure it again. -- Instead, call configureProgram directly first. conf1 <- configureProgram verbosity haskellSuiteProgram' conf0' (confdCompiler, conf2) <- requireProgram verbosity haskellSuiteProgram' conf1 extensions <- getExtensions verbosity confdCompiler languages <- getLanguages verbosity confdCompiler (compName, compVersion) <- getCompilerVersion verbosity confdCompiler let comp = Compiler { compilerId = CompilerId (HaskellSuite compName) compVersion, compilerAbiTag = Compiler.NoAbiTag, compilerCompat = [], compilerLanguages = languages, compilerExtensions = extensions, compilerProperties = M.empty } return (comp, confdCompiler, conf2) hstoolVersion :: Verbosity -> FilePath -> IO (Maybe Version) hstoolVersion = findProgramVersion "--hspkg-version" id numericVersion :: Verbosity -> FilePath -> IO (Maybe Version) numericVersion = findProgramVersion "--compiler-version" (last . words) getCompilerVersion :: Verbosity -> ConfiguredProgram -> IO (String, Version) getCompilerVersion verbosity prog = do output <- rawSystemStdout verbosity (programPath prog) ["--compiler-version"] let parts = words output name = concat $ init parts -- there shouldn't be any spaces in the name anyway versionStr = last parts version <- maybe (die "haskell-suite: couldn't determine compiler version") return $ simpleParse versionStr return (name, version) getExtensions :: Verbosity -> ConfiguredProgram -> IO [(Extension, Compiler.Flag)] getExtensions verbosity prog = do extStrs <- lines <$> rawSystemStdout verbosity (programPath prog) ["--supported-extensions"] return [ (ext, "-X" ++ display ext) | Just ext <- map simpleParse extStrs ] getLanguages :: Verbosity -> ConfiguredProgram -> IO [(Language, Compiler.Flag)] getLanguages verbosity prog = do langStrs <- lines <$> rawSystemStdout verbosity (programPath prog) ["--supported-languages"] return [ (ext, "-G" ++ display ext) | Just ext <- map simpleParse langStrs ] -- Other compilers do some kind of a packagedb stack check here. Not sure -- if we need something like that as well. getInstalledPackages :: Verbosity -> PackageDBStack -> ProgramConfiguration -> IO InstalledPackageIndex getInstalledPackages verbosity packagedbs conf = liftM (PackageIndex.fromList . concat) $ forM packagedbs $ \packagedb -> do str <- getDbProgramOutput verbosity haskellSuitePkgProgram conf ["dump", packageDbOpt packagedb] `catchExit` \_ -> die $ "pkg dump failed" case parsePackages str of Right ok -> return ok _ -> die "failed to parse output of 'pkg dump'" where parsePackages str = let parsed = map parseInstalledPackageInfo (splitPkgs str) in case [ msg | ParseFailed msg <- parsed ] of [] -> Right [ pkg | ParseOk _ pkg <- parsed ] msgs -> Left msgs splitPkgs :: String -> [String] splitPkgs = map unlines . splitWith ("---" ==) . lines where splitWith :: (a -> Bool) -> [a] -> [[a]] splitWith p xs = ys : case zs of [] -> [] _:ws -> splitWith p ws where (ys,zs) = break p xs buildLib :: Verbosity -> PackageDescription -> LocalBuildInfo -> Library -> ComponentLocalBuildInfo -> IO () buildLib verbosity pkg_descr lbi lib clbi = do -- In future, there should be a mechanism for the compiler to request any -- number of the above parameters (or their parts) — in particular, -- pieces of PackageDescription. -- -- For now, we only pass those that we know are used. let odir = buildDir lbi bi = libBuildInfo lib srcDirs = hsSourceDirs bi ++ [odir] dbStack = withPackageDB lbi language = fromMaybe Haskell98 (defaultLanguage bi) conf = withPrograms lbi pkgid = packageId pkg_descr runDbProgram verbosity haskellSuiteProgram conf $ [ "compile", "--build-dir", odir ] ++ concat [ ["-i", d] | d <- srcDirs ] ++ concat [ ["-I", d] | d <- [autogenModulesDir lbi, odir] ++ includeDirs bi ] ++ [ packageDbOpt pkgDb | pkgDb <- dbStack ] ++ [ "--package-name", display pkgid ] ++ concat [ ["--package-id", display ipkgid ] | (ipkgid, _) <- componentPackageDeps clbi ] ++ ["-G", display language] ++ concat [ ["-X", display ex] | ex <- usedExtensions bi ] ++ cppOptions (libBuildInfo lib) ++ [ display modu | modu <- libModules lib ] installLib :: Verbosity -> LocalBuildInfo -> FilePath -- ^install location -> FilePath -- ^install location for dynamic libraries -> FilePath -- ^Build location -> PackageDescription -> Library -> IO () installLib verbosity lbi targetDir dynlibTargetDir builtDir pkg lib = do let conf = withPrograms lbi runDbProgram verbosity haskellSuitePkgProgram conf $ [ "install-library" , "--build-dir", builtDir , "--target-dir", targetDir , "--dynlib-target-dir", dynlibTargetDir , "--package-id", display $ packageId pkg ] ++ map display (libModules lib) registerPackage :: Verbosity -> InstalledPackageInfo -> PackageDescription -> LocalBuildInfo -> Bool -> PackageDBStack -> IO () registerPackage verbosity installedPkgInfo _pkg lbi _inplace packageDbs = do (hspkg, _) <- requireProgram verbosity haskellSuitePkgProgram (withPrograms lbi) runProgramInvocation verbosity $ (programInvocation hspkg ["update", packageDbOpt $ last packageDbs]) { progInvokeInput = Just $ showInstalledPackageInfo installedPkgInfo } initPackageDB :: Verbosity -> ProgramConfiguration -> FilePath -> IO () initPackageDB verbosity conf dbPath = runDbProgram verbosity haskellSuitePkgProgram conf ["init", dbPath] packageDbOpt :: PackageDB -> String packageDbOpt GlobalPackageDB = "--global" packageDbOpt UserPackageDB = "--user" packageDbOpt (SpecificPackageDB db) = "--package-db=" ++ db Cabal-1.22.5.0/Distribution/Simple/Hpc.hs0000644000000000000000000001234612627136220016114 0ustar0000000000000000----------------------------------------------------------------------------- -- | -- Module : Distribution.Simple.Hpc -- Copyright : Thomas Tuegel 2011 -- License : BSD3 -- -- Maintainer : cabal-devel@haskell.org -- Portability : portable -- -- This module provides functions for locating various HPC-related paths and -- a function for adding the necessary options to a PackageDescription to -- build test suites with HPC enabled. module Distribution.Simple.Hpc ( Way(..), guessWay , htmlDir , mixDir , tixDir , tixFilePath , markupPackage , markupTest ) where import Control.Monad ( when ) import Distribution.ModuleName ( main ) import Distribution.PackageDescription ( TestSuite(..) , testModules ) import Distribution.Simple.LocalBuildInfo ( LocalBuildInfo(..) ) import Distribution.Simple.Program ( hpcProgram , requireProgramVersion ) import Distribution.Simple.Program.Hpc ( markup, union ) import Distribution.Simple.Utils ( notice ) import Distribution.Version ( anyVersion ) import Distribution.Verbosity ( Verbosity() ) import System.Directory ( createDirectoryIfMissing, doesFileExist ) import System.FilePath -- ------------------------------------------------------------------------- -- Haskell Program Coverage data Way = Vanilla | Prof | Dyn deriving (Bounded, Enum, Eq, Read, Show) hpcDir :: FilePath -- ^ \"dist/\" prefix -> Way -> FilePath -- ^ Directory containing component's HPC .mix files hpcDir distPref way = distPref "hpc" wayDir where wayDir = case way of Vanilla -> "vanilla" Prof -> "prof" Dyn -> "dyn" mixDir :: FilePath -- ^ \"dist/\" prefix -> Way -> FilePath -- ^ Component name -> FilePath -- ^ Directory containing test suite's .mix files mixDir distPref way name = hpcDir distPref way "mix" name tixDir :: FilePath -- ^ \"dist/\" prefix -> Way -> FilePath -- ^ Component name -> FilePath -- ^ Directory containing test suite's .tix files tixDir distPref way name = hpcDir distPref way "tix" name -- | Path to the .tix file containing a test suite's sum statistics. tixFilePath :: FilePath -- ^ \"dist/\" prefix -> Way -> FilePath -- ^ Component name -> FilePath -- ^ Path to test suite's .tix file tixFilePath distPref way name = tixDir distPref way name name <.> "tix" htmlDir :: FilePath -- ^ \"dist/\" prefix -> Way -> FilePath -- ^ Component name -> FilePath -- ^ Path to test suite's HTML markup directory htmlDir distPref way name = hpcDir distPref way "html" name -- | Attempt to guess the way the test suites in this package were compiled -- and linked with the library so the correct module interfaces are found. guessWay :: LocalBuildInfo -> Way guessWay lbi | withProfExe lbi = Prof | withDynExe lbi = Dyn | otherwise = Vanilla -- | Generate the HTML markup for a test suite. markupTest :: Verbosity -> LocalBuildInfo -> FilePath -- ^ \"dist/\" prefix -> String -- ^ Library name -> TestSuite -> IO () markupTest verbosity lbi distPref libName suite = do tixFileExists <- doesFileExist $ tixFilePath distPref way $ testName suite when tixFileExists $ do -- behaviour of 'markup' depends on version, so we need *a* version -- but no particular one (hpc, hpcVer, _) <- requireProgramVersion verbosity hpcProgram anyVersion (withPrograms lbi) let htmlDir_ = htmlDir distPref way $ testName suite markup hpc hpcVer verbosity (tixFilePath distPref way $ testName suite) mixDirs htmlDir_ (testModules suite ++ [ main ]) notice verbosity $ "Test coverage report written to " ++ htmlDir_ "hpc_index" <.> "html" where way = guessWay lbi mixDirs = map (mixDir distPref way) [ testName suite, libName ] -- | Generate the HTML markup for all of a package's test suites. markupPackage :: Verbosity -> LocalBuildInfo -> FilePath -- ^ \"dist/\" prefix -> String -- ^ Library name -> [TestSuite] -> IO () markupPackage verbosity lbi distPref libName suites = do let tixFiles = map (tixFilePath distPref way . testName) suites tixFilesExist <- mapM doesFileExist tixFiles when (and tixFilesExist) $ do -- behaviour of 'markup' depends on version, so we need *a* version -- but no particular one (hpc, hpcVer, _) <- requireProgramVersion verbosity hpcProgram anyVersion (withPrograms lbi) let outFile = tixFilePath distPref way libName htmlDir' = htmlDir distPref way libName excluded = concatMap testModules suites ++ [ main ] createDirectoryIfMissing True $ takeDirectory outFile union hpc verbosity tixFiles outFile excluded markup hpc hpcVer verbosity outFile mixDirs htmlDir' excluded notice verbosity $ "Package coverage report written to " ++ htmlDir' "hpc_index.html" where way = guessWay lbi mixDirs = map (mixDir distPref way) $ libName : map testName suites Cabal-1.22.5.0/Distribution/Simple/Install.hs0000644000000000000000000002051712627136220017007 0ustar0000000000000000----------------------------------------------------------------------------- -- | -- Module : Distribution.Simple.Install -- Copyright : Isaac Jones 2003-2004 -- License : BSD3 -- -- Maintainer : cabal-devel@haskell.org -- Portability : portable -- -- This is the entry point into installing a built package. Performs the -- \"@.\/setup install@\" and \"@.\/setup copy@\" actions. It moves files into -- place based on the prefix argument. It does the generic bits and then calls -- compiler-specific functions to do the rest. module Distribution.Simple.Install ( install, ) where import Distribution.PackageDescription ( PackageDescription(..), BuildInfo(..), Library(..), hasLibs, withLib, hasExes, withExe ) import Distribution.Package (Package(..)) import Distribution.Simple.LocalBuildInfo ( LocalBuildInfo(..), InstallDirs(..), absoluteInstallDirs, substPathTemplate, withLibLBI) import Distribution.Simple.BuildPaths (haddockName, haddockPref) import Distribution.Simple.Utils ( createDirectoryIfMissingVerbose , installDirectoryContents, installOrdinaryFile, isInSearchPath , die, info, notice, warn, matchDirFileGlob ) import Distribution.Simple.Compiler ( CompilerFlavor(..), compilerFlavor ) import Distribution.Simple.Setup (CopyFlags(..), fromFlag) import qualified Distribution.Simple.GHC as GHC import qualified Distribution.Simple.GHCJS as GHCJS import qualified Distribution.Simple.JHC as JHC import qualified Distribution.Simple.LHC as LHC import qualified Distribution.Simple.UHC as UHC import qualified Distribution.Simple.HaskellSuite as HaskellSuite import Control.Monad (when, unless) import System.Directory ( doesDirectoryExist, doesFileExist ) import System.FilePath ( takeFileName, takeDirectory, (), isAbsolute ) import Distribution.Verbosity import Distribution.Text ( display ) -- |Perform the \"@.\/setup install@\" and \"@.\/setup copy@\" -- actions. Move files into place based on the prefix argument. install :: PackageDescription -- ^information from the .cabal file -> LocalBuildInfo -- ^information from the configure step -> CopyFlags -- ^flags sent to copy or install -> IO () install pkg_descr lbi flags = do let distPref = fromFlag (copyDistPref flags) verbosity = fromFlag (copyVerbosity flags) copydest = fromFlag (copyDest flags) installDirs@(InstallDirs { bindir = binPref, libdir = libPref, -- dynlibdir = dynlibPref, --see TODO below datadir = dataPref, docdir = docPref, htmldir = htmlPref, haddockdir = interfacePref, includedir = incPref}) = absoluteInstallDirs pkg_descr lbi copydest --TODO: decide if we need the user to be able to control the libdir -- for shared libs independently of the one for static libs. If so -- it should also have a flag in the command line UI -- For the moment use dynlibdir = libdir dynlibPref = libPref progPrefixPref = substPathTemplate (packageId pkg_descr) lbi (progPrefix lbi) progSuffixPref = substPathTemplate (packageId pkg_descr) lbi (progSuffix lbi) docExists <- doesDirectoryExist $ haddockPref distPref pkg_descr info verbosity ("directory " ++ haddockPref distPref pkg_descr ++ " does exist: " ++ show docExists) installDataFiles verbosity pkg_descr dataPref when docExists $ do createDirectoryIfMissingVerbose verbosity True htmlPref installDirectoryContents verbosity (haddockPref distPref pkg_descr) htmlPref -- setPermissionsRecursive [Read] htmlPref -- The haddock interface file actually already got installed -- in the recursive copy, but now we install it where we actually -- want it to be (normally the same place). We could remove the -- copy in htmlPref first. let haddockInterfaceFileSrc = haddockPref distPref pkg_descr haddockName pkg_descr haddockInterfaceFileDest = interfacePref haddockName pkg_descr -- We only generate the haddock interface file for libs, So if the -- package consists only of executables there will not be one: exists <- doesFileExist haddockInterfaceFileSrc when exists $ do createDirectoryIfMissingVerbose verbosity True interfacePref installOrdinaryFile verbosity haddockInterfaceFileSrc haddockInterfaceFileDest let lfiles = licenseFiles pkg_descr unless (null lfiles) $ do createDirectoryIfMissingVerbose verbosity True docPref sequence_ [ installOrdinaryFile verbosity lfile (docPref takeFileName lfile) | lfile <- lfiles ] let buildPref = buildDir lbi when (hasLibs pkg_descr) $ notice verbosity ("Installing library in " ++ libPref) when (hasExes pkg_descr) $ do notice verbosity ("Installing executable(s) in " ++ binPref) inPath <- isInSearchPath binPref when (not inPath) $ warn verbosity ("The directory " ++ binPref ++ " is not in the system search path.") -- install include files for all compilers - they may be needed to compile -- haskell files (using the CPP extension) when (hasLibs pkg_descr) $ installIncludeFiles verbosity pkg_descr incPref case compilerFlavor (compiler lbi) of GHC -> do withLibLBI pkg_descr lbi $ GHC.installLib verbosity lbi libPref dynlibPref buildPref pkg_descr withExe pkg_descr $ GHC.installExe verbosity lbi installDirs buildPref (progPrefixPref, progSuffixPref) pkg_descr GHCJS-> do withLibLBI pkg_descr lbi $ GHCJS.installLib verbosity lbi libPref dynlibPref buildPref pkg_descr withExe pkg_descr $ GHCJS.installExe verbosity lbi installDirs buildPref (progPrefixPref, progSuffixPref) pkg_descr LHC -> do withLibLBI pkg_descr lbi $ LHC.installLib verbosity lbi libPref dynlibPref buildPref pkg_descr withExe pkg_descr $ LHC.installExe verbosity lbi installDirs buildPref (progPrefixPref, progSuffixPref) pkg_descr JHC -> do withLib pkg_descr $ JHC.installLib verbosity libPref buildPref pkg_descr withExe pkg_descr $ JHC.installExe verbosity binPref buildPref (progPrefixPref, progSuffixPref) pkg_descr UHC -> do withLib pkg_descr $ UHC.installLib verbosity lbi libPref dynlibPref buildPref pkg_descr HaskellSuite {} -> withLib pkg_descr $ HaskellSuite.installLib verbosity lbi libPref dynlibPref buildPref pkg_descr _ -> die $ "installing with " ++ display (compilerFlavor (compiler lbi)) ++ " is not implemented" -- register step should be performed by caller. -- | Install the files listed in data-files -- installDataFiles :: Verbosity -> PackageDescription -> FilePath -> IO () installDataFiles verbosity pkg_descr destDataDir = flip mapM_ (dataFiles pkg_descr) $ \ file -> do let srcDataDir = dataDir pkg_descr files <- matchDirFileGlob srcDataDir file let dir = takeDirectory file createDirectoryIfMissingVerbose verbosity True (destDataDir dir) sequence_ [ installOrdinaryFile verbosity (srcDataDir file') (destDataDir file') | file' <- files ] -- | Install the files listed in install-includes -- installIncludeFiles :: Verbosity -> PackageDescription -> FilePath -> IO () installIncludeFiles verbosity PackageDescription { library = Just lib } destIncludeDir = do incs <- mapM (findInc relincdirs) (installIncludes lbi) sequence_ [ do createDirectoryIfMissingVerbose verbosity True destDir installOrdinaryFile verbosity srcFile destFile | (relFile, srcFile) <- incs , let destFile = destIncludeDir relFile destDir = takeDirectory destFile ] where relincdirs = "." : filter (not.isAbsolute) (includeDirs lbi) lbi = libBuildInfo lib findInc [] file = die ("can't find include file " ++ file) findInc (dir:dirs) file = do let path = dir file exists <- doesFileExist path if exists then return (file, path) else findInc dirs file installIncludeFiles _ _ _ = die "installIncludeFiles: Can't happen?" Cabal-1.22.5.0/Distribution/Simple/InstallDirs.hs0000644000000000000000000005642312627136220017636 0ustar0000000000000000{-# LANGUAGE CPP, ForeignFunctionInterface #-} {-# LANGUAGE DeriveGeneric #-} ----------------------------------------------------------------------------- -- | -- Module : Distribution.Simple.InstallDirs -- Copyright : Isaac Jones 2003-2004 -- License : BSD3 -- -- Maintainer : cabal-devel@haskell.org -- Portability : portable -- -- This manages everything to do with where files get installed (though does -- not get involved with actually doing any installation). It provides an -- 'InstallDirs' type which is a set of directories for where to install -- things. It also handles the fact that we use templates in these install -- dirs. For example most install dirs are relative to some @$prefix@ and by -- changing the prefix all other dirs still end up changed appropriately. So it -- provides a 'PathTemplate' type and functions for substituting for these -- templates. module Distribution.Simple.InstallDirs ( InstallDirs(..), InstallDirTemplates, defaultInstallDirs, combineInstallDirs, absoluteInstallDirs, CopyDest(..), prefixRelativeInstallDirs, substituteInstallDirTemplates, PathTemplate, PathTemplateVariable(..), PathTemplateEnv, toPathTemplate, fromPathTemplate, substPathTemplate, initialPathTemplateEnv, platformTemplateEnv, compilerTemplateEnv, packageTemplateEnv, abiTemplateEnv, installDirsTemplateEnv, ) where import Distribution.Compat.Binary (Binary) import Data.List (isPrefixOf) import Data.Maybe (fromMaybe) #if __GLASGOW_HASKELL__ < 710 import Data.Monoid (Monoid(..)) #endif import GHC.Generics (Generic) import System.Directory (getAppUserDataDirectory) import System.FilePath ((), isPathSeparator, pathSeparator) import System.FilePath (dropDrive) import Distribution.Package ( PackageIdentifier, PackageKey, packageName, packageVersion, packageKeyLibraryName ) import Distribution.System ( OS(..), buildOS, Platform(..) ) import Distribution.Compiler ( AbiTag(..), abiTagString, CompilerInfo(..), CompilerFlavor(..) ) import Distribution.Text ( display ) #if mingw32_HOST_OS import Foreign import Foreign.C #endif -- --------------------------------------------------------------------------- -- Installation directories -- | The directories where we will install files for packages. -- -- We have several different directories for different types of files since -- many systems have conventions whereby different types of files in a package -- are installed in different directories. This is particularly the case on -- Unix style systems. -- data InstallDirs dir = InstallDirs { prefix :: dir, bindir :: dir, libdir :: dir, libsubdir :: dir, dynlibdir :: dir, libexecdir :: dir, includedir :: dir, datadir :: dir, datasubdir :: dir, docdir :: dir, mandir :: dir, htmldir :: dir, haddockdir :: dir, sysconfdir :: dir } deriving (Generic, Read, Show) instance Binary dir => Binary (InstallDirs dir) instance Functor InstallDirs where fmap f dirs = InstallDirs { prefix = f (prefix dirs), bindir = f (bindir dirs), libdir = f (libdir dirs), libsubdir = f (libsubdir dirs), dynlibdir = f (dynlibdir dirs), libexecdir = f (libexecdir dirs), includedir = f (includedir dirs), datadir = f (datadir dirs), datasubdir = f (datasubdir dirs), docdir = f (docdir dirs), mandir = f (mandir dirs), htmldir = f (htmldir dirs), haddockdir = f (haddockdir dirs), sysconfdir = f (sysconfdir dirs) } instance Monoid dir => Monoid (InstallDirs dir) where mempty = InstallDirs { prefix = mempty, bindir = mempty, libdir = mempty, libsubdir = mempty, dynlibdir = mempty, libexecdir = mempty, includedir = mempty, datadir = mempty, datasubdir = mempty, docdir = mempty, mandir = mempty, htmldir = mempty, haddockdir = mempty, sysconfdir = mempty } mappend = combineInstallDirs mappend combineInstallDirs :: (a -> b -> c) -> InstallDirs a -> InstallDirs b -> InstallDirs c combineInstallDirs combine a b = InstallDirs { prefix = prefix a `combine` prefix b, bindir = bindir a `combine` bindir b, libdir = libdir a `combine` libdir b, libsubdir = libsubdir a `combine` libsubdir b, dynlibdir = dynlibdir a `combine` dynlibdir b, libexecdir = libexecdir a `combine` libexecdir b, includedir = includedir a `combine` includedir b, datadir = datadir a `combine` datadir b, datasubdir = datasubdir a `combine` datasubdir b, docdir = docdir a `combine` docdir b, mandir = mandir a `combine` mandir b, htmldir = htmldir a `combine` htmldir b, haddockdir = haddockdir a `combine` haddockdir b, sysconfdir = sysconfdir a `combine` sysconfdir b } appendSubdirs :: (a -> a -> a) -> InstallDirs a -> InstallDirs a appendSubdirs append dirs = dirs { libdir = libdir dirs `append` libsubdir dirs, datadir = datadir dirs `append` datasubdir dirs, libsubdir = error "internal error InstallDirs.libsubdir", datasubdir = error "internal error InstallDirs.datasubdir" } -- | The installation directories in terms of 'PathTemplate's that contain -- variables. -- -- The defaults for most of the directories are relative to each other, in -- particular they are all relative to a single prefix. This makes it -- convenient for the user to override the default installation directory -- by only having to specify --prefix=... rather than overriding each -- individually. This is done by allowing $-style variables in the dirs. -- These are expanded by textual substitution (see 'substPathTemplate'). -- -- A few of these installation directories are split into two components, the -- dir and subdir. The full installation path is formed by combining the two -- together with @\/@. The reason for this is compatibility with other Unix -- build systems which also support @--libdir@ and @--datadir@. We would like -- users to be able to configure @--libdir=\/usr\/lib64@ for example but -- because by default we want to support installing multiple versions of -- packages and building the same package for multiple compilers we append the -- libsubdir to get: @\/usr\/lib64\/$libname\/$compiler@. -- -- An additional complication is the need to support relocatable packages on -- systems which support such things, like Windows. -- type InstallDirTemplates = InstallDirs PathTemplate -- --------------------------------------------------------------------------- -- Default installation directories defaultInstallDirs :: CompilerFlavor -> Bool -> Bool -> IO InstallDirTemplates defaultInstallDirs comp userInstall _hasLibs = do installPrefix <- if userInstall then getAppUserDataDirectory "cabal" else case buildOS of Windows -> do windowsProgramFilesDir <- getWindowsProgramFilesDir return (windowsProgramFilesDir "Haskell") _ -> return "/usr/local" installLibDir <- case buildOS of Windows -> return "$prefix" _ -> case comp of LHC | userInstall -> getAppUserDataDirectory "lhc" _ -> return ("$prefix" "lib") return $ fmap toPathTemplate $ InstallDirs { prefix = installPrefix, bindir = "$prefix" "bin", libdir = installLibDir, libsubdir = case comp of JHC -> "$compiler" LHC -> "$compiler" UHC -> "$pkgid" _other -> "$abi" "$libname", dynlibdir = "$libdir", libexecdir = case buildOS of Windows -> "$prefix" "$libname" _other -> "$prefix" "libexec", includedir = "$libdir" "$libsubdir" "include", datadir = case buildOS of Windows -> "$prefix" _other -> "$prefix" "share", datasubdir = "$abi" "$pkgid", docdir = "$datadir" "doc" "$abi" "$pkgid", mandir = "$datadir" "man", htmldir = "$docdir" "html", haddockdir = "$htmldir", sysconfdir = "$prefix" "etc" } -- --------------------------------------------------------------------------- -- Converting directories, absolute or prefix-relative -- | Substitute the install dir templates into each other. -- -- To prevent cyclic substitutions, only some variables are allowed in -- particular dir templates. If out of scope vars are present, they are not -- substituted for. Checking for any remaining unsubstituted vars can be done -- as a subsequent operation. -- -- The reason it is done this way is so that in 'prefixRelativeInstallDirs' we -- can replace 'prefix' with the 'PrefixVar' and get resulting -- 'PathTemplate's that still have the 'PrefixVar' in them. Doing this makes it -- each to check which paths are relative to the $prefix. -- substituteInstallDirTemplates :: PathTemplateEnv -> InstallDirTemplates -> InstallDirTemplates substituteInstallDirTemplates env dirs = dirs' where dirs' = InstallDirs { -- So this specifies exactly which vars are allowed in each template prefix = subst prefix [], bindir = subst bindir [prefixVar], libdir = subst libdir [prefixVar, bindirVar], libsubdir = subst libsubdir [], dynlibdir = subst dynlibdir [prefixVar, bindirVar, libdirVar], libexecdir = subst libexecdir prefixBinLibVars, includedir = subst includedir prefixBinLibVars, datadir = subst datadir prefixBinLibVars, datasubdir = subst datasubdir [], docdir = subst docdir prefixBinLibDataVars, mandir = subst mandir (prefixBinLibDataVars ++ [docdirVar]), htmldir = subst htmldir (prefixBinLibDataVars ++ [docdirVar]), haddockdir = subst haddockdir (prefixBinLibDataVars ++ [docdirVar, htmldirVar]), sysconfdir = subst sysconfdir prefixBinLibVars } subst dir env' = substPathTemplate (env'++env) (dir dirs) prefixVar = (PrefixVar, prefix dirs') bindirVar = (BindirVar, bindir dirs') libdirVar = (LibdirVar, libdir dirs') libsubdirVar = (LibsubdirVar, libsubdir dirs') datadirVar = (DatadirVar, datadir dirs') datasubdirVar = (DatasubdirVar, datasubdir dirs') docdirVar = (DocdirVar, docdir dirs') htmldirVar = (HtmldirVar, htmldir dirs') prefixBinLibVars = [prefixVar, bindirVar, libdirVar, libsubdirVar] prefixBinLibDataVars = prefixBinLibVars ++ [datadirVar, datasubdirVar] -- | Convert from abstract install directories to actual absolute ones by -- substituting for all the variables in the abstract paths, to get real -- absolute path. absoluteInstallDirs :: PackageIdentifier -> PackageKey -> CompilerInfo -> CopyDest -> Platform -> InstallDirs PathTemplate -> InstallDirs FilePath absoluteInstallDirs pkgId pkg_key compilerId copydest platform dirs = (case copydest of CopyTo destdir -> fmap ((destdir ) . dropDrive) _ -> id) . appendSubdirs () . fmap fromPathTemplate $ substituteInstallDirTemplates env dirs where env = initialPathTemplateEnv pkgId pkg_key compilerId platform -- |The location prefix for the /copy/ command. data CopyDest = NoCopyDest | CopyTo FilePath deriving (Eq, Show) -- | Check which of the paths are relative to the installation $prefix. -- -- If any of the paths are not relative, ie they are absolute paths, then it -- prevents us from making a relocatable package (also known as a \"prefix -- independent\" package). -- prefixRelativeInstallDirs :: PackageIdentifier -> PackageKey -> CompilerInfo -> Platform -> InstallDirTemplates -> InstallDirs (Maybe FilePath) prefixRelativeInstallDirs pkgId pkg_key compilerId platform dirs = fmap relative . appendSubdirs combinePathTemplate $ -- substitute the path template into each other, except that we map -- \$prefix back to $prefix. We're trying to end up with templates that -- mention no vars except $prefix. substituteInstallDirTemplates env dirs { prefix = PathTemplate [Variable PrefixVar] } where env = initialPathTemplateEnv pkgId pkg_key compilerId platform -- If it starts with $prefix then it's relative and produce the relative -- path by stripping off $prefix/ or $prefix relative dir = case dir of PathTemplate cs -> fmap (fromPathTemplate . PathTemplate) (relative' cs) relative' (Variable PrefixVar : Ordinary (s:rest) : rest') | isPathSeparator s = Just (Ordinary rest : rest') relative' (Variable PrefixVar : rest) = Just rest relative' _ = Nothing -- --------------------------------------------------------------------------- -- Path templates -- | An abstract path, possibly containing variables that need to be -- substituted for to get a real 'FilePath'. -- newtype PathTemplate = PathTemplate [PathComponent] deriving (Eq, Generic, Ord) instance Binary PathTemplate data PathComponent = Ordinary FilePath | Variable PathTemplateVariable deriving (Eq, Ord, Generic) instance Binary PathComponent data PathTemplateVariable = PrefixVar -- ^ The @$prefix@ path variable | BindirVar -- ^ The @$bindir@ path variable | LibdirVar -- ^ The @$libdir@ path variable | LibsubdirVar -- ^ The @$libsubdir@ path variable | DatadirVar -- ^ The @$datadir@ path variable | DatasubdirVar -- ^ The @$datasubdir@ path variable | DocdirVar -- ^ The @$docdir@ path variable | HtmldirVar -- ^ The @$htmldir@ path variable | PkgNameVar -- ^ The @$pkg@ package name path variable | PkgVerVar -- ^ The @$version@ package version path variable | PkgIdVar -- ^ The @$pkgid@ package Id path variable, eg @foo-1.0@ | PkgKeyVar -- ^ The @$pkgkey@ package key path variable | LibNameVar -- ^ The @$libname@ expanded package key path variable | CompilerVar -- ^ The compiler name and version, eg @ghc-6.6.1@ | OSVar -- ^ The operating system name, eg @windows@ or @linux@ | ArchVar -- ^ The CPU architecture name, eg @i386@ or @x86_64@ | AbiVar -- ^ The Compiler's ABI identifier, $arch-$os-$compiler-$abitag | AbiTagVar -- ^ The optional ABI tag for the compiler | ExecutableNameVar -- ^ The executable name; used in shell wrappers | TestSuiteNameVar -- ^ The name of the test suite being run | TestSuiteResultVar -- ^ The result of the test suite being run, eg -- @pass@, @fail@, or @error@. | BenchmarkNameVar -- ^ The name of the benchmark being run deriving (Eq, Ord, Generic) instance Binary PathTemplateVariable type PathTemplateEnv = [(PathTemplateVariable, PathTemplate)] -- | Convert a 'FilePath' to a 'PathTemplate' including any template vars. -- toPathTemplate :: FilePath -> PathTemplate toPathTemplate = PathTemplate . read -- | Convert back to a path, any remaining vars are included -- fromPathTemplate :: PathTemplate -> FilePath fromPathTemplate (PathTemplate template) = show template combinePathTemplate :: PathTemplate -> PathTemplate -> PathTemplate combinePathTemplate (PathTemplate t1) (PathTemplate t2) = PathTemplate (t1 ++ [Ordinary [pathSeparator]] ++ t2) substPathTemplate :: PathTemplateEnv -> PathTemplate -> PathTemplate substPathTemplate environment (PathTemplate template) = PathTemplate (concatMap subst template) where subst component@(Ordinary _) = [component] subst component@(Variable variable) = case lookup variable environment of Just (PathTemplate components) -> components Nothing -> [component] -- | The initial environment has all the static stuff but no paths initialPathTemplateEnv :: PackageIdentifier -> PackageKey -> CompilerInfo -> Platform -> PathTemplateEnv initialPathTemplateEnv pkgId pkg_key compiler platform = packageTemplateEnv pkgId pkg_key ++ compilerTemplateEnv compiler ++ platformTemplateEnv platform ++ abiTemplateEnv compiler platform packageTemplateEnv :: PackageIdentifier -> PackageKey -> PathTemplateEnv packageTemplateEnv pkgId pkg_key = [(PkgNameVar, PathTemplate [Ordinary $ display (packageName pkgId)]) ,(PkgVerVar, PathTemplate [Ordinary $ display (packageVersion pkgId)]) ,(PkgKeyVar, PathTemplate [Ordinary $ display pkg_key]) ,(LibNameVar, PathTemplate [Ordinary $ packageKeyLibraryName pkgId pkg_key]) ,(PkgIdVar, PathTemplate [Ordinary $ display pkgId]) ] compilerTemplateEnv :: CompilerInfo -> PathTemplateEnv compilerTemplateEnv compiler = [(CompilerVar, PathTemplate [Ordinary $ display (compilerInfoId compiler)]) ] platformTemplateEnv :: Platform -> PathTemplateEnv platformTemplateEnv (Platform arch os) = [(OSVar, PathTemplate [Ordinary $ display os]) ,(ArchVar, PathTemplate [Ordinary $ display arch]) ] abiTemplateEnv :: CompilerInfo -> Platform -> PathTemplateEnv abiTemplateEnv compiler (Platform arch os) = [(AbiVar, PathTemplate [Ordinary $ display arch ++ '-':display os ++ '-':display (compilerInfoId compiler) ++ case compilerInfoAbiTag compiler of NoAbiTag -> "" AbiTag tag -> '-':tag]) ,(AbiTagVar, PathTemplate [Ordinary $ abiTagString (compilerInfoAbiTag compiler)]) ] installDirsTemplateEnv :: InstallDirs PathTemplate -> PathTemplateEnv installDirsTemplateEnv dirs = [(PrefixVar, prefix dirs) ,(BindirVar, bindir dirs) ,(LibdirVar, libdir dirs) ,(LibsubdirVar, libsubdir dirs) ,(DatadirVar, datadir dirs) ,(DatasubdirVar, datasubdir dirs) ,(DocdirVar, docdir dirs) ,(HtmldirVar, htmldir dirs) ] -- --------------------------------------------------------------------------- -- Parsing and showing path templates: -- The textual format is that of an ordinary Haskell String, eg -- "$prefix/bin" -- and this gets parsed to the internal representation as a sequence of path -- spans which are either strings or variables, eg: -- PathTemplate [Variable PrefixVar, Ordinary "/bin" ] instance Show PathTemplateVariable where show PrefixVar = "prefix" show PkgKeyVar = "pkgkey" show LibNameVar = "libname" show BindirVar = "bindir" show LibdirVar = "libdir" show LibsubdirVar = "libsubdir" show DatadirVar = "datadir" show DatasubdirVar = "datasubdir" show DocdirVar = "docdir" show HtmldirVar = "htmldir" show PkgNameVar = "pkg" show PkgVerVar = "version" show PkgIdVar = "pkgid" show CompilerVar = "compiler" show OSVar = "os" show ArchVar = "arch" show AbiTagVar = "abitag" show AbiVar = "abi" show ExecutableNameVar = "executablename" show TestSuiteNameVar = "test-suite" show TestSuiteResultVar = "result" show BenchmarkNameVar = "benchmark" instance Read PathTemplateVariable where readsPrec _ s = take 1 [ (var, drop (length varStr) s) | (varStr, var) <- vars , varStr `isPrefixOf` s ] -- NB: order matters! Longer strings first where vars = [("prefix", PrefixVar) ,("bindir", BindirVar) ,("libdir", LibdirVar) ,("libsubdir", LibsubdirVar) ,("datadir", DatadirVar) ,("datasubdir", DatasubdirVar) ,("docdir", DocdirVar) ,("htmldir", HtmldirVar) ,("pkgid", PkgIdVar) ,("pkgkey", PkgKeyVar) ,("libname", LibNameVar) ,("pkg", PkgNameVar) ,("version", PkgVerVar) ,("compiler", CompilerVar) ,("os", OSVar) ,("arch", ArchVar) ,("abitag", AbiTagVar) ,("abi", AbiVar) ,("executablename", ExecutableNameVar) ,("test-suite", TestSuiteNameVar) ,("result", TestSuiteResultVar) ,("benchmark", BenchmarkNameVar)] instance Show PathComponent where show (Ordinary path) = path show (Variable var) = '$':show var showList = foldr (\x -> (shows x .)) id instance Read PathComponent where -- for some reason we collapse multiple $ symbols here readsPrec _ = lex0 where lex0 [] = [] lex0 ('$':'$':s') = lex0 ('$':s') lex0 ('$':s') = case [ (Variable var, s'') | (var, s'') <- reads s' ] of [] -> lex1 "$" s' ok -> ok lex0 s' = lex1 [] s' lex1 "" "" = [] lex1 acc "" = [(Ordinary (reverse acc), "")] lex1 acc ('$':'$':s) = lex1 acc ('$':s) lex1 acc ('$':s) = [(Ordinary (reverse acc), '$':s)] lex1 acc (c:s) = lex1 (c:acc) s readList [] = [([],"")] readList s = [ (component:components, s'') | (component, s') <- reads s , (components, s'') <- readList s' ] instance Show PathTemplate where show (PathTemplate template) = show (show template) instance Read PathTemplate where readsPrec p s = [ (PathTemplate template, s') | (path, s') <- readsPrec p s , (template, "") <- reads path ] -- --------------------------------------------------------------------------- -- Internal utilities getWindowsProgramFilesDir :: IO FilePath getWindowsProgramFilesDir = do #if mingw32_HOST_OS m <- shGetFolderPath csidl_PROGRAM_FILES #else let m = Nothing #endif return (fromMaybe "C:\\Program Files" m) #if mingw32_HOST_OS shGetFolderPath :: CInt -> IO (Maybe FilePath) shGetFolderPath n = allocaArray long_path_size $ \pPath -> do r <- c_SHGetFolderPath nullPtr n nullPtr 0 pPath if (r /= 0) then return Nothing else do s <- peekCWString pPath; return (Just s) where long_path_size = 1024 -- MAX_PATH is 260, this should be plenty csidl_PROGRAM_FILES :: CInt csidl_PROGRAM_FILES = 0x0026 -- csidl_PROGRAM_FILES_COMMON :: CInt -- csidl_PROGRAM_FILES_COMMON = 0x002b #ifdef x86_64_HOST_ARCH #define CALLCONV ccall #else #define CALLCONV stdcall #endif foreign import CALLCONV unsafe "shlobj.h SHGetFolderPathW" c_SHGetFolderPath :: Ptr () -> CInt -> Ptr () -> CInt -> CWString -> IO CInt #endif Cabal-1.22.5.0/Distribution/Simple/JHC.hs0000644000000000000000000002064012627136220016002 0ustar0000000000000000----------------------------------------------------------------------------- -- | -- Module : Distribution.Simple.JHC -- Copyright : Isaac Jones 2003-2006 -- License : BSD3 -- -- Maintainer : cabal-devel@haskell.org -- Portability : portable -- -- This module contains most of the JHC-specific code for configuring, building -- and installing packages. module Distribution.Simple.JHC ( configure, getInstalledPackages, buildLib, buildExe, installLib, installExe ) where import Distribution.PackageDescription as PD ( PackageDescription(..), BuildInfo(..), Executable(..) , Library(..), libModules, hcOptions, usedExtensions ) import Distribution.InstalledPackageInfo ( emptyInstalledPackageInfo, ) import qualified Distribution.InstalledPackageInfo as InstalledPackageInfo import Distribution.Simple.PackageIndex (InstalledPackageIndex) import qualified Distribution.Simple.PackageIndex as PackageIndex import Distribution.Simple.LocalBuildInfo ( LocalBuildInfo(..), ComponentLocalBuildInfo(..) ) import Distribution.Simple.BuildPaths ( autogenModulesDir, exeExtension ) import Distribution.Simple.Compiler ( CompilerFlavor(..), CompilerId(..), Compiler(..), AbiTag(..) , PackageDBStack, Flag, languageToFlags, extensionsToFlags ) import Language.Haskell.Extension ( Language(Haskell98), Extension(..), KnownExtension(..)) import Distribution.Simple.Program ( ConfiguredProgram(..), jhcProgram, ProgramConfiguration , userMaybeSpecifyPath, requireProgramVersion, lookupProgram , rawSystemProgram, rawSystemProgramStdoutConf ) import Distribution.Version ( Version(..), orLaterVersion ) import Distribution.Package ( Package(..), InstalledPackageId(InstalledPackageId), pkgName, pkgVersion, ) import Distribution.Simple.Utils ( createDirectoryIfMissingVerbose, writeFileAtomic , installOrdinaryFile, installExecutableFile , intercalate ) import System.FilePath ( () ) import Distribution.Verbosity import Distribution.Text ( Text(parse), display ) import Distribution.Compat.ReadP ( readP_to_S, string, skipSpaces ) import Distribution.System ( Platform ) import Data.List ( nub ) import Data.Char ( isSpace ) import qualified Data.Map as M ( empty ) import Data.Maybe ( fromMaybe ) import qualified Data.ByteString.Lazy.Char8 as BS.Char8 -- ----------------------------------------------------------------------------- -- Configuring configure :: Verbosity -> Maybe FilePath -> Maybe FilePath -> ProgramConfiguration -> IO (Compiler, Maybe Platform, ProgramConfiguration) configure verbosity hcPath _hcPkgPath conf = do (jhcProg, _, conf') <- requireProgramVersion verbosity jhcProgram (orLaterVersion (Version [0,7,2] [])) (userMaybeSpecifyPath "jhc" hcPath conf) let Just version = programVersion jhcProg comp = Compiler { compilerId = CompilerId JHC version, compilerAbiTag = NoAbiTag, compilerCompat = [], compilerLanguages = jhcLanguages, compilerExtensions = jhcLanguageExtensions, compilerProperties = M.empty } compPlatform = Nothing return (comp, compPlatform, conf') jhcLanguages :: [(Language, Flag)] jhcLanguages = [(Haskell98, "")] -- | The flags for the supported extensions jhcLanguageExtensions :: [(Extension, Flag)] jhcLanguageExtensions = [(EnableExtension TypeSynonymInstances , "") ,(DisableExtension TypeSynonymInstances , "") ,(EnableExtension ForeignFunctionInterface , "") ,(DisableExtension ForeignFunctionInterface , "") ,(EnableExtension ImplicitPrelude , "") -- Wrong ,(DisableExtension ImplicitPrelude , "--noprelude") ,(EnableExtension CPP , "-fcpp") ,(DisableExtension CPP , "-fno-cpp") ] getInstalledPackages :: Verbosity -> PackageDBStack -> ProgramConfiguration -> IO InstalledPackageIndex getInstalledPackages verbosity _packageDBs conf = do -- jhc --list-libraries lists all available libraries. -- How shall I find out, whether they are global or local -- without checking all files and locations? str <- rawSystemProgramStdoutConf verbosity jhcProgram conf ["--list-libraries"] let pCheck :: [(a, String)] -> [a] pCheck rs = [ r | (r,s) <- rs, all isSpace s ] let parseLine ln = pCheck (readP_to_S (skipSpaces >> string "Name:" >> skipSpaces >> parse) ln) return $ PackageIndex.fromList $ map (\p -> emptyInstalledPackageInfo { InstalledPackageInfo.installedPackageId = InstalledPackageId (display p), InstalledPackageInfo.sourcePackageId = p }) $ concatMap parseLine $ lines str -- ----------------------------------------------------------------------------- -- Building -- | Building a package for JHC. -- Currently C source files are not supported. buildLib :: Verbosity -> PackageDescription -> LocalBuildInfo -> Library -> ComponentLocalBuildInfo -> IO () buildLib verbosity pkg_descr lbi lib clbi = do let Just jhcProg = lookupProgram jhcProgram (withPrograms lbi) let libBi = libBuildInfo lib let args = constructJHCCmdLine lbi libBi clbi (buildDir lbi) verbosity let pkgid = display (packageId pkg_descr) pfile = buildDir lbi "jhc-pkg.conf" hlfile= buildDir lbi (pkgid ++ ".hl") writeFileAtomic pfile . BS.Char8.pack $ jhcPkgConf pkg_descr rawSystemProgram verbosity jhcProg $ ["--build-hl="++pfile, "-o", hlfile] ++ args ++ map display (libModules lib) -- | Building an executable for JHC. -- Currently C source files are not supported. buildExe :: Verbosity -> PackageDescription -> LocalBuildInfo -> Executable -> ComponentLocalBuildInfo -> IO () buildExe verbosity _pkg_descr lbi exe clbi = do let Just jhcProg = lookupProgram jhcProgram (withPrograms lbi) let exeBi = buildInfo exe let out = buildDir lbi exeName exe let args = constructJHCCmdLine lbi exeBi clbi (buildDir lbi) verbosity rawSystemProgram verbosity jhcProg (["-o",out] ++ args ++ [modulePath exe]) constructJHCCmdLine :: LocalBuildInfo -> BuildInfo -> ComponentLocalBuildInfo -> FilePath -> Verbosity -> [String] constructJHCCmdLine lbi bi clbi _odir verbosity = (if verbosity >= deafening then ["-v"] else []) ++ hcOptions JHC bi ++ languageToFlags (compiler lbi) (defaultLanguage bi) ++ extensionsToFlags (compiler lbi) (usedExtensions bi) ++ ["--noauto","-i-"] ++ concat [["-i", l] | l <- nub (hsSourceDirs bi)] ++ ["-i", autogenModulesDir lbi] ++ ["-optc" ++ opt | opt <- PD.ccOptions bi] -- It would be better if JHC would accept package names with versions, -- but JHC-0.7.2 doesn't accept this. -- Thus, we have to strip the version with 'pkgName'. ++ (concat [ ["-p", display (pkgName pkgid)] | (_, pkgid) <- componentPackageDeps clbi ]) jhcPkgConf :: PackageDescription -> String jhcPkgConf pd = let sline name sel = name ++ ": "++sel pd lib = fromMaybe (error "no library available") . library comma = intercalate "," . map display in unlines [sline "name" (display . pkgName . packageId) ,sline "version" (display . pkgVersion . packageId) ,sline "exposed-modules" (comma . PD.exposedModules . lib) ,sline "hidden-modules" (comma . otherModules . libBuildInfo . lib) ] installLib :: Verbosity -> FilePath -> FilePath -> PackageDescription -> Library -> IO () installLib verb dest build_dir pkg_descr _ = do let p = display (packageId pkg_descr)++".hl" createDirectoryIfMissingVerbose verb True dest installOrdinaryFile verb (build_dir p) (dest p) installExe :: Verbosity -> FilePath -> FilePath -> (FilePath,FilePath) -> PackageDescription -> Executable -> IO () installExe verb dest build_dir (progprefix,progsuffix) _ exe = do let exe_name = exeName exe src = exe_name exeExtension out = (progprefix ++ exe_name ++ progsuffix) exeExtension createDirectoryIfMissingVerbose verb True dest installExecutableFile verb (build_dir src) (dest out) Cabal-1.22.5.0/Distribution/Simple/LHC.hs0000644000000000000000000010224412627136220016005 0ustar0000000000000000{-# LANGUAGE CPP #-} ----------------------------------------------------------------------------- -- | -- Module : Distribution.Simple.LHC -- Copyright : Isaac Jones 2003-2007 -- License : BSD3 -- -- Maintainer : cabal-devel@haskell.org -- Portability : portable -- -- This is a fairly large module. It contains most of the GHC-specific code for -- configuring, building and installing packages. It also exports a function -- for finding out what packages are already installed. Configuring involves -- finding the @ghc@ and @ghc-pkg@ programs, finding what language extensions -- this version of ghc supports and returning a 'Compiler' value. -- -- 'getInstalledPackages' involves calling the @ghc-pkg@ program to find out -- what packages are installed. -- -- Building is somewhat complex as there is quite a bit of information to take -- into account. We have to build libs and programs, possibly for profiling and -- shared libs. We have to support building libraries that will be usable by -- GHCi and also ghc's @-split-objs@ feature. We have to compile any C files -- using ghc. Linking, especially for @split-objs@ is remarkably complex, -- partly because there tend to be 1,000's of @.o@ files and this can often be -- more than we can pass to the @ld@ or @ar@ programs in one go. -- -- Installing for libs and exes involves finding the right files and copying -- them to the right places. One of the more tricky things about this module is -- remembering the layout of files in the build directory (which is not -- explicitly documented) and thus what search dirs are used for various kinds -- of files. module Distribution.Simple.LHC ( configure, getInstalledPackages, buildLib, buildExe, installLib, installExe, registerPackage, hcPkgInfo, ghcOptions, ghcVerbosityOptions ) where import Distribution.PackageDescription as PD ( PackageDescription(..), BuildInfo(..), Executable(..) , Library(..), libModules, hcOptions, hcProfOptions, hcSharedOptions , usedExtensions, allExtensions ) import Distribution.InstalledPackageInfo ( InstalledPackageInfo , parseInstalledPackageInfo ) import qualified Distribution.InstalledPackageInfo as InstalledPackageInfo ( InstalledPackageInfo_(..) ) import Distribution.Simple.PackageIndex import qualified Distribution.Simple.PackageIndex as PackageIndex import Distribution.ParseUtils ( ParseResult(..) ) import Distribution.Simple.LocalBuildInfo ( LocalBuildInfo(..), ComponentLocalBuildInfo(..), LibraryName(..) ) import Distribution.Simple.InstallDirs import Distribution.Simple.BuildPaths import Distribution.Simple.Utils import Distribution.Package ( Package(..) ) import qualified Distribution.ModuleName as ModuleName import Distribution.Simple.Program ( Program(..), ConfiguredProgram(..), ProgramConfiguration , ProgramSearchPath, ProgramLocation(..) , rawSystemProgram, rawSystemProgramConf , rawSystemProgramStdout, rawSystemProgramStdoutConf , requireProgramVersion , userMaybeSpecifyPath, programPath, lookupProgram, addKnownProgram , arProgram, ldProgram , gccProgram, stripProgram , lhcProgram, lhcPkgProgram ) import qualified Distribution.Simple.Program.HcPkg as HcPkg import Distribution.Simple.Compiler ( CompilerFlavor(..), CompilerId(..), Compiler(..), compilerVersion , OptimisationLevel(..), PackageDB(..), PackageDBStack, AbiTag(..) , Flag, languageToFlags, extensionsToFlags ) import Distribution.Version ( Version(..), orLaterVersion ) import Distribution.System ( OS(..), buildOS ) import Distribution.Verbosity import Distribution.Text ( display, simpleParse ) import Language.Haskell.Extension ( Language(Haskell98), Extension(..), KnownExtension(..) ) import Control.Monad ( unless, when ) import Data.List import qualified Data.Map as M ( empty ) import Data.Maybe ( catMaybes ) #if __GLASGOW_HASKELL__ < 710 import Data.Monoid ( Monoid(..) ) #endif import System.Directory ( removeFile, renameFile, getDirectoryContents, doesFileExist, getTemporaryDirectory ) import System.FilePath ( (), (<.>), takeExtension, takeDirectory, replaceExtension ) import System.IO (hClose, hPutStrLn) import Distribution.Compat.Exception (catchExit, catchIO) import Distribution.System ( Platform ) -- ----------------------------------------------------------------------------- -- Configuring configure :: Verbosity -> Maybe FilePath -> Maybe FilePath -> ProgramConfiguration -> IO (Compiler, Maybe Platform, ProgramConfiguration) configure verbosity hcPath hcPkgPath conf = do (lhcProg, lhcVersion, conf') <- requireProgramVersion verbosity lhcProgram (orLaterVersion (Version [0,7] [])) (userMaybeSpecifyPath "lhc" hcPath conf) (lhcPkgProg, lhcPkgVersion, conf'') <- requireProgramVersion verbosity lhcPkgProgram (orLaterVersion (Version [0,7] [])) (userMaybeSpecifyPath "lhc-pkg" hcPkgPath conf') when (lhcVersion /= lhcPkgVersion) $ die $ "Version mismatch between lhc and lhc-pkg: " ++ programPath lhcProg ++ " is version " ++ display lhcVersion ++ " " ++ programPath lhcPkgProg ++ " is version " ++ display lhcPkgVersion languages <- getLanguages verbosity lhcProg extensions <- getExtensions verbosity lhcProg let comp = Compiler { compilerId = CompilerId LHC lhcVersion, compilerAbiTag = NoAbiTag, compilerCompat = [], compilerLanguages = languages, compilerExtensions = extensions, compilerProperties = M.empty } conf''' = configureToolchain lhcProg conf'' -- configure gcc and ld compPlatform = Nothing return (comp, compPlatform, conf''') -- | Adjust the way we find and configure gcc and ld -- configureToolchain :: ConfiguredProgram -> ProgramConfiguration -> ProgramConfiguration configureToolchain lhcProg = addKnownProgram gccProgram { programFindLocation = findProg gccProgram (baseDir "gcc.exe"), programPostConf = configureGcc } . addKnownProgram ldProgram { programFindLocation = findProg ldProgram (libDir "ld.exe"), programPostConf = configureLd } where compilerDir = takeDirectory (programPath lhcProg) baseDir = takeDirectory compilerDir libDir = baseDir "gcc-lib" includeDir = baseDir "include" "mingw" isWindows = case buildOS of Windows -> True; _ -> False -- on Windows finding and configuring ghc's gcc and ld is a bit special findProg :: Program -> FilePath -> Verbosity -> ProgramSearchPath -> IO (Maybe FilePath) findProg prog location | isWindows = \verbosity searchpath -> do exists <- doesFileExist location if exists then return (Just location) else do warn verbosity ("Couldn't find " ++ programName prog ++ " where I expected it. Trying the search path.") programFindLocation prog verbosity searchpath | otherwise = programFindLocation prog configureGcc :: Verbosity -> ConfiguredProgram -> IO ConfiguredProgram configureGcc | isWindows = \_ gccProg -> case programLocation gccProg of -- if it's found on system then it means we're using the result -- of programFindLocation above rather than a user-supplied path -- that means we should add this extra flag to tell ghc's gcc -- where it lives and thus where gcc can find its various files: FoundOnSystem {} -> return gccProg { programDefaultArgs = ["-B" ++ libDir, "-I" ++ includeDir] } UserSpecified {} -> return gccProg | otherwise = \_ gccProg -> return gccProg -- we need to find out if ld supports the -x flag configureLd :: Verbosity -> ConfiguredProgram -> IO ConfiguredProgram configureLd verbosity ldProg = do tempDir <- getTemporaryDirectory ldx <- withTempFile tempDir ".c" $ \testcfile testchnd -> withTempFile tempDir ".o" $ \testofile testohnd -> do hPutStrLn testchnd "int foo() { return 0; }" hClose testchnd; hClose testohnd rawSystemProgram verbosity lhcProg ["-c", testcfile, "-o", testofile] withTempFile tempDir ".o" $ \testofile' testohnd' -> do hClose testohnd' _ <- rawSystemProgramStdout verbosity ldProg ["-x", "-r", testofile, "-o", testofile'] return True `catchIO` (\_ -> return False) `catchExit` (\_ -> return False) if ldx then return ldProg { programDefaultArgs = ["-x"] } else return ldProg getLanguages :: Verbosity -> ConfiguredProgram -> IO [(Language, Flag)] getLanguages _ _ = return [(Haskell98, "")] --FIXME: does lhc support -XHaskell98 flag? from what version? getExtensions :: Verbosity -> ConfiguredProgram -> IO [(Extension, Flag)] getExtensions verbosity lhcProg = do exts <- rawSystemStdout verbosity (programPath lhcProg) ["--supported-languages"] -- GHC has the annoying habit of inverting some of the extensions -- so we have to try parsing ("No" ++ ghcExtensionName) first let readExtension str = do ext <- simpleParse ("No" ++ str) case ext of UnknownExtension _ -> simpleParse str _ -> return ext return $ [ (ext, "-X" ++ display ext) | Just ext <- map readExtension (lines exts) ] getInstalledPackages :: Verbosity -> PackageDBStack -> ProgramConfiguration -> IO InstalledPackageIndex getInstalledPackages verbosity packagedbs conf = do checkPackageDbStack packagedbs pkgss <- getInstalledPackages' lhcPkg verbosity packagedbs conf let indexes = [ PackageIndex.fromList (map (substTopDir topDir) pkgs) | (_, pkgs) <- pkgss ] return $! (mconcat indexes) where -- On Windows, various fields have $topdir/foo rather than full -- paths. We need to substitute the right value in so that when -- we, for example, call gcc, we have proper paths to give it Just ghcProg = lookupProgram lhcProgram conf Just lhcPkg = lookupProgram lhcPkgProgram conf compilerDir = takeDirectory (programPath ghcProg) topDir = takeDirectory compilerDir checkPackageDbStack :: PackageDBStack -> IO () checkPackageDbStack (GlobalPackageDB:rest) | GlobalPackageDB `notElem` rest = return () checkPackageDbStack _ = die $ "GHC.getInstalledPackages: the global package db must be " ++ "specified first and cannot be specified multiple times" -- | Get the packages from specific PackageDBs, not cumulative. -- getInstalledPackages' :: ConfiguredProgram -> Verbosity -> [PackageDB] -> ProgramConfiguration -> IO [(PackageDB, [InstalledPackageInfo])] getInstalledPackages' lhcPkg verbosity packagedbs conf = sequence [ do str <- rawSystemProgramStdoutConf verbosity lhcPkgProgram conf ["dump", packageDbGhcPkgFlag packagedb] `catchExit` \_ -> die $ "ghc-pkg dump failed" case parsePackages str of Left ok -> return (packagedb, ok) _ -> die "failed to parse output of 'ghc-pkg dump'" | packagedb <- packagedbs ] where parsePackages str = let parsed = map parseInstalledPackageInfo (splitPkgs str) in case [ msg | ParseFailed msg <- parsed ] of [] -> Left [ pkg | ParseOk _ pkg <- parsed ] msgs -> Right msgs splitPkgs :: String -> [String] splitPkgs = map unlines . splitWith ("---" ==) . lines where splitWith :: (a -> Bool) -> [a] -> [[a]] splitWith p xs = ys : case zs of [] -> [] _:ws -> splitWith p ws where (ys,zs) = break p xs packageDbGhcPkgFlag GlobalPackageDB = "--global" packageDbGhcPkgFlag UserPackageDB = "--user" packageDbGhcPkgFlag (SpecificPackageDB path) = "--" ++ packageDbFlag ++ "=" ++ path packageDbFlag | programVersion lhcPkg < Just (Version [7,5] []) = "package-conf" | otherwise = "package-db" substTopDir :: FilePath -> InstalledPackageInfo -> InstalledPackageInfo substTopDir topDir ipo = ipo { InstalledPackageInfo.importDirs = map f (InstalledPackageInfo.importDirs ipo), InstalledPackageInfo.libraryDirs = map f (InstalledPackageInfo.libraryDirs ipo), InstalledPackageInfo.includeDirs = map f (InstalledPackageInfo.includeDirs ipo), InstalledPackageInfo.frameworkDirs = map f (InstalledPackageInfo.frameworkDirs ipo), InstalledPackageInfo.haddockInterfaces = map f (InstalledPackageInfo.haddockInterfaces ipo), InstalledPackageInfo.haddockHTMLs = map f (InstalledPackageInfo.haddockHTMLs ipo) } where f ('$':'t':'o':'p':'d':'i':'r':rest) = topDir ++ rest f x = x -- ----------------------------------------------------------------------------- -- Building -- | Build a library with LHC. -- buildLib :: Verbosity -> PackageDescription -> LocalBuildInfo -> Library -> ComponentLocalBuildInfo -> IO () buildLib verbosity pkg_descr lbi lib clbi = do libName <- case componentLibraries clbi of [libName] -> return libName [] -> die "No library name found when building library" _ -> die "Multiple library names found when building library" let pref = buildDir lbi pkgid = packageId pkg_descr runGhcProg = rawSystemProgramConf verbosity lhcProgram (withPrograms lbi) ifVanillaLib forceVanilla = when (forceVanilla || withVanillaLib lbi) ifProfLib = when (withProfLib lbi) ifSharedLib = when (withSharedLib lbi) ifGHCiLib = when (withGHCiLib lbi && withVanillaLib lbi) libBi <- hackThreadedFlag verbosity (compiler lbi) (withProfLib lbi) (libBuildInfo lib) let libTargetDir = pref forceVanillaLib = EnableExtension TemplateHaskell `elem` allExtensions libBi -- TH always needs vanilla libs, even when building for profiling createDirectoryIfMissingVerbose verbosity True libTargetDir -- TODO: do we need to put hs-boot files into place for mutually recursive modules? let ghcArgs = ["-package-name", display pkgid ] ++ constructGHCCmdLine lbi libBi clbi libTargetDir verbosity ++ map display (libModules lib) lhcWrap x = ["--build-library", "--ghc-opts=" ++ unwords x] ghcArgsProf = ghcArgs ++ ["-prof", "-hisuf", "p_hi", "-osuf", "p_o" ] ++ hcProfOptions GHC libBi ghcArgsShared = ghcArgs ++ ["-dynamic", "-hisuf", "dyn_hi", "-osuf", "dyn_o", "-fPIC" ] ++ hcSharedOptions GHC libBi unless (null (libModules lib)) $ do ifVanillaLib forceVanillaLib (runGhcProg $ lhcWrap ghcArgs) ifProfLib (runGhcProg $ lhcWrap ghcArgsProf) ifSharedLib (runGhcProg $ lhcWrap ghcArgsShared) -- build any C sources unless (null (cSources libBi)) $ do info verbosity "Building C Sources..." sequence_ [do let (odir,args) = constructCcCmdLine lbi libBi clbi pref filename verbosity createDirectoryIfMissingVerbose verbosity True odir runGhcProg args ifSharedLib (runGhcProg (args ++ ["-fPIC", "-osuf dyn_o"])) | filename <- cSources libBi] -- link: info verbosity "Linking..." let cObjs = map (`replaceExtension` objExtension) (cSources libBi) cSharedObjs = map (`replaceExtension` ("dyn_" ++ objExtension)) (cSources libBi) cid = compilerId (compiler lbi) vanillaLibFilePath = libTargetDir mkLibName libName profileLibFilePath = libTargetDir mkProfLibName libName sharedLibFilePath = libTargetDir mkSharedLibName cid libName ghciLibFilePath = libTargetDir mkGHCiLibName libName stubObjs <- fmap catMaybes $ sequence [ findFileWithExtension [objExtension] [libTargetDir] (ModuleName.toFilePath x ++"_stub") | x <- libModules lib ] stubProfObjs <- fmap catMaybes $ sequence [ findFileWithExtension ["p_" ++ objExtension] [libTargetDir] (ModuleName.toFilePath x ++"_stub") | x <- libModules lib ] stubSharedObjs <- fmap catMaybes $ sequence [ findFileWithExtension ["dyn_" ++ objExtension] [libTargetDir] (ModuleName.toFilePath x ++"_stub") | x <- libModules lib ] hObjs <- getHaskellObjects lib lbi pref objExtension True hProfObjs <- if (withProfLib lbi) then getHaskellObjects lib lbi pref ("p_" ++ objExtension) True else return [] hSharedObjs <- if (withSharedLib lbi) then getHaskellObjects lib lbi pref ("dyn_" ++ objExtension) False else return [] unless (null hObjs && null cObjs && null stubObjs) $ do -- first remove library files if they exists sequence_ [ removeFile libFilePath `catchIO` \_ -> return () | libFilePath <- [vanillaLibFilePath, profileLibFilePath ,sharedLibFilePath, ghciLibFilePath] ] let arVerbosity | verbosity >= deafening = "v" | verbosity >= normal = "" | otherwise = "c" arArgs = ["q"++ arVerbosity] ++ [vanillaLibFilePath] arObjArgs = hObjs ++ map (pref ) cObjs ++ stubObjs arProfArgs = ["q"++ arVerbosity] ++ [profileLibFilePath] arProfObjArgs = hProfObjs ++ map (pref ) cObjs ++ stubProfObjs ldArgs = ["-r"] ++ ["-o", ghciLibFilePath <.> "tmp"] ldObjArgs = hObjs ++ map (pref ) cObjs ++ stubObjs ghcSharedObjArgs = hSharedObjs ++ map (pref ) cSharedObjs ++ stubSharedObjs -- After the relocation lib is created we invoke ghc -shared -- with the dependencies spelled out as -package arguments -- and ghc invokes the linker with the proper library paths ghcSharedLinkArgs = [ "-no-auto-link-packages", "-shared", "-dynamic", "-o", sharedLibFilePath ] ++ ghcSharedObjArgs ++ ["-package-name", display pkgid ] ++ ghcPackageFlags lbi clbi ++ ["-l"++extraLib | extraLib <- extraLibs libBi] ++ ["-L"++extraLibDir | extraLibDir <- extraLibDirs libBi] runLd ldLibName args = do exists <- doesFileExist ldLibName -- This method is called iteratively by xargs. The -- output goes to .tmp, and any existing file -- named is included when linking. The -- output is renamed to . rawSystemProgramConf verbosity ldProgram (withPrograms lbi) (args ++ if exists then [ldLibName] else []) renameFile (ldLibName <.> "tmp") ldLibName runAr = rawSystemProgramConf verbosity arProgram (withPrograms lbi) --TODO: discover this at configure time or runtime on Unix -- The value is 32k on Windows and POSIX specifies a minimum of 4k -- but all sensible Unixes use more than 4k. -- we could use getSysVar ArgumentLimit but that's in the Unix lib maxCommandLineSize = 30 * 1024 ifVanillaLib False $ xargs maxCommandLineSize runAr arArgs arObjArgs ifProfLib $ xargs maxCommandLineSize runAr arProfArgs arProfObjArgs ifGHCiLib $ xargs maxCommandLineSize (runLd ghciLibFilePath) ldArgs ldObjArgs ifSharedLib $ runGhcProg ghcSharedLinkArgs -- | Build an executable with LHC. -- buildExe :: Verbosity -> PackageDescription -> LocalBuildInfo -> Executable -> ComponentLocalBuildInfo -> IO () buildExe verbosity _pkg_descr lbi exe@Executable { exeName = exeName', modulePath = modPath } clbi = do let pref = buildDir lbi runGhcProg = rawSystemProgramConf verbosity lhcProgram (withPrograms lbi) exeBi <- hackThreadedFlag verbosity (compiler lbi) (withProfExe lbi) (buildInfo exe) -- exeNameReal, the name that GHC really uses (with .exe on Windows) let exeNameReal = exeName' <.> (if null $ takeExtension exeName' then exeExtension else "") let targetDir = pref exeName' let exeDir = targetDir (exeName' ++ "-tmp") createDirectoryIfMissingVerbose verbosity True targetDir createDirectoryIfMissingVerbose verbosity True exeDir -- TODO: do we need to put hs-boot files into place for mutually recursive modules? -- FIX: what about exeName.hi-boot? -- build executables unless (null (cSources exeBi)) $ do info verbosity "Building C Sources." sequence_ [do let (odir,args) = constructCcCmdLine lbi exeBi clbi exeDir filename verbosity createDirectoryIfMissingVerbose verbosity True odir runGhcProg args | filename <- cSources exeBi] srcMainFile <- findFile (exeDir : hsSourceDirs exeBi) modPath let cObjs = map (`replaceExtension` objExtension) (cSources exeBi) let lhcWrap x = ("--ghc-opts\"":x) ++ ["\""] let binArgs linkExe profExe = (if linkExe then ["-o", targetDir exeNameReal] else ["-c"]) ++ constructGHCCmdLine lbi exeBi clbi exeDir verbosity ++ [exeDir x | x <- cObjs] ++ [srcMainFile] ++ ["-optl" ++ opt | opt <- PD.ldOptions exeBi] ++ ["-l"++lib | lib <- extraLibs exeBi] ++ ["-L"++libDir | libDir <- extraLibDirs exeBi] ++ concat [["-framework", f] | f <- PD.frameworks exeBi] ++ if profExe then ["-prof", "-hisuf", "p_hi", "-osuf", "p_o" ] ++ hcProfOptions GHC exeBi else [] -- For building exe's for profiling that use TH we actually -- have to build twice, once without profiling and the again -- with profiling. This is because the code that TH needs to -- run at compile time needs to be the vanilla ABI so it can -- be loaded up and run by the compiler. when (withProfExe lbi && EnableExtension TemplateHaskell `elem` allExtensions exeBi) (runGhcProg $ lhcWrap (binArgs False False)) runGhcProg (binArgs True (withProfExe lbi)) -- | Filter the "-threaded" flag when profiling as it does not -- work with ghc-6.8 and older. hackThreadedFlag :: Verbosity -> Compiler -> Bool -> BuildInfo -> IO BuildInfo hackThreadedFlag verbosity comp prof bi | not mustFilterThreaded = return bi | otherwise = do warn verbosity $ "The ghc flag '-threaded' is not compatible with " ++ "profiling in ghc-6.8 and older. It will be disabled." return bi { options = filterHcOptions (/= "-threaded") (options bi) } where mustFilterThreaded = prof && compilerVersion comp < Version [6, 10] [] && "-threaded" `elem` hcOptions GHC bi filterHcOptions p hcoptss = [ (hc, if hc == GHC then filter p opts else opts) | (hc, opts) <- hcoptss ] -- when using -split-objs, we need to search for object files in the -- Module_split directory for each module. getHaskellObjects :: Library -> LocalBuildInfo -> FilePath -> String -> Bool -> IO [FilePath] getHaskellObjects lib lbi pref wanted_obj_ext allow_split_objs | splitObjs lbi && allow_split_objs = do let dirs = [ pref (ModuleName.toFilePath x ++ "_split") | x <- libModules lib ] objss <- mapM getDirectoryContents dirs let objs = [ dir obj | (objs',dir) <- zip objss dirs, obj <- objs', let obj_ext = takeExtension obj, '.':wanted_obj_ext == obj_ext ] return objs | otherwise = return [ pref ModuleName.toFilePath x <.> wanted_obj_ext | x <- libModules lib ] constructGHCCmdLine :: LocalBuildInfo -> BuildInfo -> ComponentLocalBuildInfo -> FilePath -> Verbosity -> [String] constructGHCCmdLine lbi bi clbi odir verbosity = ["--make"] ++ ghcVerbosityOptions verbosity -- Unsupported extensions have already been checked by configure ++ ghcOptions lbi bi clbi odir ghcVerbosityOptions :: Verbosity -> [String] ghcVerbosityOptions verbosity | verbosity >= deafening = ["-v"] | verbosity >= normal = [] | otherwise = ["-w", "-v0"] ghcOptions :: LocalBuildInfo -> BuildInfo -> ComponentLocalBuildInfo -> FilePath -> [String] ghcOptions lbi bi clbi odir = ["-hide-all-packages"] ++ ghcPackageDbOptions lbi ++ (if splitObjs lbi then ["-split-objs"] else []) ++ ["-i"] ++ ["-i" ++ odir] ++ ["-i" ++ l | l <- nub (hsSourceDirs bi)] ++ ["-i" ++ autogenModulesDir lbi] ++ ["-I" ++ autogenModulesDir lbi] ++ ["-I" ++ odir] ++ ["-I" ++ dir | dir <- PD.includeDirs bi] ++ ["-optP" ++ opt | opt <- cppOptions bi] ++ [ "-optP-include", "-optP"++ (autogenModulesDir lbi cppHeaderName) ] ++ [ "-#include \"" ++ inc ++ "\"" | inc <- PD.includes bi ] ++ [ "-odir", odir, "-hidir", odir ] ++ (if compilerVersion c >= Version [6,8] [] then ["-stubdir", odir] else []) ++ ghcPackageFlags lbi clbi ++ (case withOptimization lbi of NoOptimisation -> [] NormalOptimisation -> ["-O"] MaximumOptimisation -> ["-O2"]) ++ hcOptions GHC bi ++ languageToFlags c (defaultLanguage bi) ++ extensionsToFlags c (usedExtensions bi) where c = compiler lbi ghcPackageFlags :: LocalBuildInfo -> ComponentLocalBuildInfo -> [String] ghcPackageFlags lbi clbi | ghcVer >= Version [6,11] [] = concat [ ["-package-id", display ipkgid] | (ipkgid, _) <- componentPackageDeps clbi ] | otherwise = concat [ ["-package", display pkgid] | (_, pkgid) <- componentPackageDeps clbi ] where ghcVer = compilerVersion (compiler lbi) ghcPackageDbOptions :: LocalBuildInfo -> [String] ghcPackageDbOptions lbi = case dbstack of (GlobalPackageDB:UserPackageDB:dbs) -> concatMap specific dbs (GlobalPackageDB:dbs) -> ("-no-user-" ++ packageDbFlag) : concatMap specific dbs _ -> ierror where specific (SpecificPackageDB db) = [ '-':packageDbFlag, db ] specific _ = ierror ierror = error ("internal error: unexpected package db stack: " ++ show dbstack) dbstack = withPackageDB lbi packageDbFlag | compilerVersion (compiler lbi) < Version [7,5] [] = "package-conf" | otherwise = "package-db" constructCcCmdLine :: LocalBuildInfo -> BuildInfo -> ComponentLocalBuildInfo -> FilePath -> FilePath -> Verbosity -> (FilePath,[String]) constructCcCmdLine lbi bi clbi pref filename verbosity = let odir | compilerVersion (compiler lbi) >= Version [6,4,1] [] = pref | otherwise = pref takeDirectory filename -- ghc 6.4.1 fixed a bug in -odir handling -- for C compilations. in (odir, ghcCcOptions lbi bi clbi odir ++ (if verbosity >= deafening then ["-v"] else []) ++ ["-c",filename]) ghcCcOptions :: LocalBuildInfo -> BuildInfo -> ComponentLocalBuildInfo -> FilePath -> [String] ghcCcOptions lbi bi clbi odir = ["-I" ++ dir | dir <- PD.includeDirs bi] ++ ghcPackageDbOptions lbi ++ ghcPackageFlags lbi clbi ++ ["-optc" ++ opt | opt <- PD.ccOptions bi] ++ (case withOptimization lbi of NoOptimisation -> [] _ -> ["-optc-O2"]) ++ ["-odir", odir] mkGHCiLibName :: LibraryName -> String mkGHCiLibName (LibraryName lib) = lib <.> "o" -- ----------------------------------------------------------------------------- -- Installing -- |Install executables for GHC. installExe :: Verbosity -> LocalBuildInfo -> InstallDirs FilePath -- ^Where to copy the files to -> FilePath -- ^Build location -> (FilePath, FilePath) -- ^Executable (prefix,suffix) -> PackageDescription -> Executable -> IO () installExe verbosity lbi installDirs buildPref (progprefix, progsuffix) _pkg exe = do let binDir = bindir installDirs createDirectoryIfMissingVerbose verbosity True binDir let exeFileName = exeName exe <.> exeExtension fixedExeBaseName = progprefix ++ exeName exe ++ progsuffix installBinary dest = do installExecutableFile verbosity (buildPref exeName exe exeFileName) (dest <.> exeExtension) stripExe verbosity lbi exeFileName (dest <.> exeExtension) installBinary (binDir fixedExeBaseName) stripExe :: Verbosity -> LocalBuildInfo -> FilePath -> FilePath -> IO () stripExe verbosity lbi name path = when (stripExes lbi) $ case lookupProgram stripProgram (withPrograms lbi) of Just strip -> rawSystemProgram verbosity strip args Nothing -> unless (buildOS == Windows) $ -- Don't bother warning on windows, we don't expect them to -- have the strip program anyway. warn verbosity $ "Unable to strip executable '" ++ name ++ "' (missing the 'strip' program)" where args = path : case buildOS of OSX -> ["-x"] -- By default, stripping the ghc binary on at least -- some OS X installations causes: -- HSbase-3.0.o: unknown symbol `_environ'" -- The -x flag fixes that. _ -> [] -- |Install for ghc, .hi, .a and, if --with-ghci given, .o installLib :: Verbosity -> LocalBuildInfo -> FilePath -- ^install location -> FilePath -- ^install location for dynamic libraries -> FilePath -- ^Build location -> PackageDescription -> Library -> ComponentLocalBuildInfo -> IO () installLib verbosity lbi targetDir dynlibTargetDir builtDir _pkg lib clbi = do -- copy .hi files over: let copy src dst n = do createDirectoryIfMissingVerbose verbosity True dst installOrdinaryFile verbosity (src n) (dst n) copyModuleFiles ext = findModuleFiles [builtDir] [ext] (libModules lib) >>= installOrdinaryFiles verbosity targetDir ifVanilla $ copyModuleFiles "hi" ifProf $ copyModuleFiles "p_hi" hcrFiles <- findModuleFiles (builtDir : hsSourceDirs (libBuildInfo lib)) ["hcr"] (libModules lib) flip mapM_ hcrFiles $ \(srcBase, srcFile) -> runLhc ["--install-library", srcBase srcFile] -- copy the built library files over: ifVanilla $ mapM_ (copy builtDir targetDir) vanillaLibNames ifProf $ mapM_ (copy builtDir targetDir) profileLibNames ifGHCi $ mapM_ (copy builtDir targetDir) ghciLibNames ifShared $ mapM_ (copy builtDir dynlibTargetDir) sharedLibNames where cid = compilerId (compiler lbi) libNames = componentLibraries clbi vanillaLibNames = map mkLibName libNames profileLibNames = map mkProfLibName libNames ghciLibNames = map mkGHCiLibName libNames sharedLibNames = map (mkSharedLibName cid) libNames hasLib = not $ null (libModules lib) && null (cSources (libBuildInfo lib)) ifVanilla = when (hasLib && withVanillaLib lbi) ifProf = when (hasLib && withProfLib lbi) ifGHCi = when (hasLib && withGHCiLib lbi) ifShared = when (hasLib && withSharedLib lbi) runLhc = rawSystemProgramConf verbosity lhcProgram (withPrograms lbi) -- ----------------------------------------------------------------------------- -- Registering registerPackage :: Verbosity -> InstalledPackageInfo -> PackageDescription -> LocalBuildInfo -> Bool -> PackageDBStack -> IO () registerPackage verbosity installedPkgInfo _pkg lbi _inplace packageDbs = HcPkg.reregister (hcPkgInfo $ withPrograms lbi) verbosity packageDbs (Right installedPkgInfo) hcPkgInfo :: ProgramConfiguration -> HcPkg.HcPkgInfo hcPkgInfo conf = HcPkg.HcPkgInfo { HcPkg.hcPkgProgram = lhcPkgProg , HcPkg.noPkgDbStack = False , HcPkg.noVerboseFlag = False , HcPkg.flagPackageConf = False , HcPkg.useSingleFileDb = True } where Just lhcPkgProg = lookupProgram lhcPkgProgram conf Cabal-1.22.5.0/Distribution/Simple/LocalBuildInfo.hs0000644000000000000000000005104512627136220020227 0ustar0000000000000000{-# LANGUAGE DeriveGeneric #-} ----------------------------------------------------------------------------- -- | -- Module : Distribution.Simple.LocalBuildInfo -- Copyright : Isaac Jones 2003-2004 -- License : BSD3 -- -- Maintainer : cabal-devel@haskell.org -- Portability : portable -- -- Once a package has been configured we have resolved conditionals and -- dependencies, configured the compiler and other needed external programs. -- The 'LocalBuildInfo' is used to hold all this information. It holds the -- install dirs, the compiler, the exact package dependencies, the configured -- programs, the package database to use and a bunch of miscellaneous configure -- flags. It gets saved and reloaded from a file (@dist\/setup-config@). It gets -- passed in to very many subsequent build actions. module Distribution.Simple.LocalBuildInfo ( LocalBuildInfo(..), externalPackageDeps, inplacePackageId, -- * Buildable package components Component(..), ComponentName(..), showComponentName, ComponentLocalBuildInfo(..), LibraryName(..), foldComponent, componentName, componentBuildInfo, componentEnabled, componentDisabledReason, ComponentDisabledReason(..), pkgComponents, pkgEnabledComponents, lookupComponent, getComponent, getComponentLocalBuildInfo, allComponentsInBuildOrder, componentsInBuildOrder, checkComponentsCyclic, depLibraryPaths, withAllComponentsInBuildOrder, withComponentsInBuildOrder, withComponentsLBI, withLibLBI, withExeLBI, withTestLBI, -- * Installation directories module Distribution.Simple.InstallDirs, absoluteInstallDirs, prefixRelativeInstallDirs, substPathTemplate ) where import Distribution.Simple.InstallDirs hiding (absoluteInstallDirs, prefixRelativeInstallDirs, substPathTemplate, ) import qualified Distribution.Simple.InstallDirs as InstallDirs import Distribution.Simple.Program (ProgramConfiguration) import Distribution.InstalledPackageInfo (InstalledPackageInfo) import Distribution.PackageDescription ( PackageDescription(..), withLib, Library(libBuildInfo), withExe , Executable(exeName, buildInfo), withTest, TestSuite(..) , BuildInfo(buildable), Benchmark(..), ModuleRenaming(..) ) import qualified Distribution.InstalledPackageInfo as Installed import Distribution.Package ( PackageId, Package(..), InstalledPackageId(..), PackageKey , PackageName ) import Distribution.Simple.Compiler ( Compiler, compilerInfo, PackageDBStack, DebugInfoLevel , OptimisationLevel ) import Distribution.Simple.PackageIndex ( InstalledPackageIndex, allPackages ) import Distribution.ModuleName ( ModuleName ) import Distribution.Simple.Setup ( ConfigFlags ) import Distribution.Simple.Utils ( shortRelativePath ) import Distribution.Text ( display ) import Distribution.System ( Platform (..) ) import Data.Array ((!)) import Distribution.Compat.Binary (Binary) import Data.Graph import Data.List (nub, find, stripPrefix) import Data.Maybe import Data.Tree (flatten) import GHC.Generics (Generic) import Data.Map (Map) import System.Directory (doesDirectoryExist, canonicalizePath) -- | Data cached after configuration step. See also -- 'Distribution.Simple.Setup.ConfigFlags'. data LocalBuildInfo = LocalBuildInfo { configFlags :: ConfigFlags, -- ^ Options passed to the configuration step. -- Needed to re-run configuration when .cabal is out of date extraConfigArgs :: [String], -- ^ Extra args on the command line for the configuration step. -- Needed to re-run configuration when .cabal is out of date installDirTemplates :: InstallDirTemplates, -- ^ The installation directories for the various different -- kinds of files --TODO: inplaceDirTemplates :: InstallDirs FilePath compiler :: Compiler, -- ^ The compiler we're building with hostPlatform :: Platform, -- ^ The platform we're building for buildDir :: FilePath, -- ^ Where to build the package. componentsConfigs :: [(ComponentName, ComponentLocalBuildInfo, [ComponentName])], -- ^ All the components to build, ordered by topological sort, and with their dependencies -- over the intrapackage dependency graph installedPkgs :: InstalledPackageIndex, -- ^ All the info about the installed packages that the -- current package depends on (directly or indirectly). pkgDescrFile :: Maybe FilePath, -- ^ the filename containing the .cabal file, if available localPkgDescr :: PackageDescription, -- ^ The resolved package description, that does not contain -- any conditionals. pkgKey :: PackageKey, -- ^ The package key for the current build, calculated from -- the package ID and the dependency graph. instantiatedWith :: [(ModuleName, (InstalledPackageInfo, ModuleName))], withPrograms :: ProgramConfiguration, -- ^Location and args for all programs withPackageDB :: PackageDBStack, -- ^What package database to use, global\/user withVanillaLib:: Bool, -- ^Whether to build normal libs. withProfLib :: Bool, -- ^Whether to build profiling versions of libs. withSharedLib :: Bool, -- ^Whether to build shared versions of libs. withDynExe :: Bool, -- ^Whether to link executables dynamically withProfExe :: Bool, -- ^Whether to build executables for profiling. withOptimization :: OptimisationLevel, -- ^Whether to build with optimization (if available). withDebugInfo :: DebugInfoLevel, -- ^Whether to emit debug info (if available). withGHCiLib :: Bool, -- ^Whether to build libs suitable for use with GHCi. splitObjs :: Bool, -- ^Use -split-objs with GHC, if available stripExes :: Bool, -- ^Whether to strip executables during install stripLibs :: Bool, -- ^Whether to strip libraries during install progPrefix :: PathTemplate, -- ^Prefix to be prepended to installed executables progSuffix :: PathTemplate, -- ^Suffix to be appended to installed executables relocatable :: Bool -- ^Whether to build a relocatable package } deriving (Generic, Read, Show) instance Binary LocalBuildInfo -- | External package dependencies for the package as a whole. This is the -- union of the individual 'componentPackageDeps', less any internal deps. externalPackageDeps :: LocalBuildInfo -> [(InstalledPackageId, PackageId)] externalPackageDeps lbi = -- TODO: what about non-buildable components? nub [ (ipkgid, pkgid) | (_,clbi,_) <- componentsConfigs lbi , (ipkgid, pkgid) <- componentPackageDeps clbi , not (internal pkgid) ] where -- True if this dependency is an internal one (depends on the library -- defined in the same package). internal pkgid = pkgid == packageId (localPkgDescr lbi) -- | The installed package Id we use for local packages registered in the local -- package db. This is what is used for intra-package deps between components. -- inplacePackageId :: PackageId -> InstalledPackageId inplacePackageId pkgid = InstalledPackageId (display pkgid ++ "-inplace") -- ----------------------------------------------------------------------------- -- Buildable components data Component = CLib Library | CExe Executable | CTest TestSuite | CBench Benchmark deriving (Show, Eq, Read) data ComponentName = CLibName -- currently only a single lib | CExeName String | CTestName String | CBenchName String deriving (Eq, Generic, Ord, Read, Show) instance Binary ComponentName showComponentName :: ComponentName -> String showComponentName CLibName = "library" showComponentName (CExeName name) = "executable '" ++ name ++ "'" showComponentName (CTestName name) = "test suite '" ++ name ++ "'" showComponentName (CBenchName name) = "benchmark '" ++ name ++ "'" data ComponentLocalBuildInfo = LibComponentLocalBuildInfo { -- | Resolved internal and external package dependencies for this component. -- The 'BuildInfo' specifies a set of build dependencies that must be -- satisfied in terms of version ranges. This field fixes those dependencies -- to the specific versions available on this machine for this compiler. componentPackageDeps :: [(InstalledPackageId, PackageId)], componentExposedModules :: [Installed.ExposedModule], componentPackageRenaming :: Map PackageName ModuleRenaming, componentLibraries :: [LibraryName] } | ExeComponentLocalBuildInfo { componentPackageDeps :: [(InstalledPackageId, PackageId)], componentPackageRenaming :: Map PackageName ModuleRenaming } | TestComponentLocalBuildInfo { componentPackageDeps :: [(InstalledPackageId, PackageId)], componentPackageRenaming :: Map PackageName ModuleRenaming } | BenchComponentLocalBuildInfo { componentPackageDeps :: [(InstalledPackageId, PackageId)], componentPackageRenaming :: Map PackageName ModuleRenaming } deriving (Generic, Read, Show) instance Binary ComponentLocalBuildInfo foldComponent :: (Library -> a) -> (Executable -> a) -> (TestSuite -> a) -> (Benchmark -> a) -> Component -> a foldComponent f _ _ _ (CLib lib) = f lib foldComponent _ f _ _ (CExe exe) = f exe foldComponent _ _ f _ (CTest tst) = f tst foldComponent _ _ _ f (CBench bch) = f bch data LibraryName = LibraryName String deriving (Generic, Read, Show) instance Binary LibraryName componentBuildInfo :: Component -> BuildInfo componentBuildInfo = foldComponent libBuildInfo buildInfo testBuildInfo benchmarkBuildInfo componentName :: Component -> ComponentName componentName = foldComponent (const CLibName) (CExeName . exeName) (CTestName . testName) (CBenchName . benchmarkName) -- | All the components in the package (libs, exes, or test suites). -- pkgComponents :: PackageDescription -> [Component] pkgComponents pkg = [ CLib lib | Just lib <- [library pkg] ] ++ [ CExe exe | exe <- executables pkg ] ++ [ CTest tst | tst <- testSuites pkg ] ++ [ CBench bm | bm <- benchmarks pkg ] -- | All the components in the package that are buildable and enabled. -- Thus this excludes non-buildable components and test suites or benchmarks -- that have been disabled. -- pkgEnabledComponents :: PackageDescription -> [Component] pkgEnabledComponents = filter componentEnabled . pkgComponents componentEnabled :: Component -> Bool componentEnabled = isNothing . componentDisabledReason data ComponentDisabledReason = DisabledComponent | DisabledAllTests | DisabledAllBenchmarks componentDisabledReason :: Component -> Maybe ComponentDisabledReason componentDisabledReason (CLib lib) | not (buildable (libBuildInfo lib)) = Just DisabledComponent componentDisabledReason (CExe exe) | not (buildable (buildInfo exe)) = Just DisabledComponent componentDisabledReason (CTest tst) | not (buildable (testBuildInfo tst)) = Just DisabledComponent | not (testEnabled tst) = Just DisabledAllTests componentDisabledReason (CBench bm) | not (buildable (benchmarkBuildInfo bm)) = Just DisabledComponent | not (benchmarkEnabled bm) = Just DisabledAllBenchmarks componentDisabledReason _ = Nothing lookupComponent :: PackageDescription -> ComponentName -> Maybe Component lookupComponent pkg CLibName = fmap CLib $ library pkg lookupComponent pkg (CExeName name) = fmap CExe $ find ((name ==) . exeName) (executables pkg) lookupComponent pkg (CTestName name) = fmap CTest $ find ((name ==) . testName) (testSuites pkg) lookupComponent pkg (CBenchName name) = fmap CBench $ find ((name ==) . benchmarkName) (benchmarks pkg) getComponent :: PackageDescription -> ComponentName -> Component getComponent pkg cname = case lookupComponent pkg cname of Just cpnt -> cpnt Nothing -> missingComponent where missingComponent = error $ "internal error: the package description contains no " ++ "component corresponding to " ++ show cname getComponentLocalBuildInfo :: LocalBuildInfo -> ComponentName -> ComponentLocalBuildInfo getComponentLocalBuildInfo lbi cname = case [ clbi | (cname', clbi, _) <- componentsConfigs lbi , cname == cname' ] of [clbi] -> clbi _ -> missingComponent where missingComponent = error $ "internal error: there is no configuration data " ++ "for component " ++ show cname -- |If the package description has a library section, call the given -- function with the library build info as argument. Extended version of -- 'withLib' that also gives corresponding build info. withLibLBI :: PackageDescription -> LocalBuildInfo -> (Library -> ComponentLocalBuildInfo -> IO ()) -> IO () withLibLBI pkg_descr lbi f = withLib pkg_descr $ \lib -> f lib (getComponentLocalBuildInfo lbi CLibName) -- | Perform the action on each buildable 'Executable' in the package -- description. Extended version of 'withExe' that also gives corresponding -- build info. withExeLBI :: PackageDescription -> LocalBuildInfo -> (Executable -> ComponentLocalBuildInfo -> IO ()) -> IO () withExeLBI pkg_descr lbi f = withExe pkg_descr $ \exe -> f exe (getComponentLocalBuildInfo lbi (CExeName (exeName exe))) withTestLBI :: PackageDescription -> LocalBuildInfo -> (TestSuite -> ComponentLocalBuildInfo -> IO ()) -> IO () withTestLBI pkg_descr lbi f = withTest pkg_descr $ \test -> f test (getComponentLocalBuildInfo lbi (CTestName (testName test))) {-# DEPRECATED withComponentsLBI "Use withAllComponentsInBuildOrder" #-} withComponentsLBI :: PackageDescription -> LocalBuildInfo -> (Component -> ComponentLocalBuildInfo -> IO ()) -> IO () withComponentsLBI = withAllComponentsInBuildOrder -- | Perform the action on each buildable 'Library' or 'Executable' (Component) -- in the PackageDescription, subject to the build order specified by the -- 'compBuildOrder' field of the given 'LocalBuildInfo' withAllComponentsInBuildOrder :: PackageDescription -> LocalBuildInfo -> (Component -> ComponentLocalBuildInfo -> IO ()) -> IO () withAllComponentsInBuildOrder pkg lbi f = sequence_ [ f (getComponent pkg cname) clbi | (cname, clbi) <- allComponentsInBuildOrder lbi ] withComponentsInBuildOrder :: PackageDescription -> LocalBuildInfo -> [ComponentName] -> (Component -> ComponentLocalBuildInfo -> IO ()) -> IO () withComponentsInBuildOrder pkg lbi cnames f = sequence_ [ f (getComponent pkg cname') clbi | (cname', clbi) <- componentsInBuildOrder lbi cnames ] allComponentsInBuildOrder :: LocalBuildInfo -> [(ComponentName, ComponentLocalBuildInfo)] allComponentsInBuildOrder lbi = componentsInBuildOrder lbi [ cname | (cname, _, _) <- componentsConfigs lbi ] componentsInBuildOrder :: LocalBuildInfo -> [ComponentName] -> [(ComponentName, ComponentLocalBuildInfo)] componentsInBuildOrder lbi cnames = map ((\(clbi,cname,_) -> (cname,clbi)) . vertexToNode) . postOrder graph . map (\cname -> fromMaybe (noSuchComp cname) (keyToVertex cname)) $ cnames where (graph, vertexToNode, keyToVertex) = graphFromEdges (map (\(a,b,c) -> (b,a,c)) (componentsConfigs lbi)) noSuchComp cname = error $ "internal error: componentsInBuildOrder: " ++ "no such component: " ++ show cname postOrder :: Graph -> [Vertex] -> [Vertex] postOrder g vs = postorderF (dfs g vs) [] postorderF :: Forest a -> [a] -> [a] postorderF ts = foldr (.) id $ map postorderT ts postorderT :: Tree a -> [a] -> [a] postorderT (Node a ts) = postorderF ts . (a :) checkComponentsCyclic :: Ord key => [(node, key, [key])] -> Maybe [(node, key, [key])] checkComponentsCyclic es = let (graph, vertexToNode, _) = graphFromEdges es cycles = [ flatten c | c <- scc graph, isCycle c ] isCycle (Node v []) = selfCyclic v isCycle _ = True selfCyclic v = v `elem` graph ! v in case cycles of [] -> Nothing (c:_) -> Just (map vertexToNode c) -- | Determine the directories containing the dynamic libraries of the -- transitive dependencies of the component we are building. -- -- When wanted, and possible, returns paths relative to the installDirs 'prefix' depLibraryPaths :: Bool -- ^ Building for inplace? -> Bool -- ^ Generate prefix-relative library paths -> LocalBuildInfo -> ComponentLocalBuildInfo -- ^ Component that is being built -> IO [FilePath] depLibraryPaths inplace relative lbi clbi = do let pkgDescr = localPkgDescr lbi installDirs = absoluteInstallDirs pkgDescr lbi NoCopyDest executable = case clbi of ExeComponentLocalBuildInfo {} -> True _ -> False relDir | executable = bindir installDirs | otherwise = libdir installDirs let hasInternalDeps = not $ null $ [ pkgid | (_,pkgid) <- componentPackageDeps clbi , internal pkgid ] let ipkgs = allPackages (installedPkgs lbi) allDepLibDirs = concatMap Installed.libraryDirs ipkgs internalLib | inplace = buildDir lbi | otherwise = libdir installDirs allDepLibDirs' = if hasInternalDeps then internalLib : allDepLibDirs else allDepLibDirs allDepLibDirsC <- mapM canonicalizePathNoFail allDepLibDirs' let p = prefix installDirs prefixRelative l = isJust (stripPrefix p l) libPaths | relative && prefixRelative relDir = map (\l -> if prefixRelative l then shortRelativePath relDir l else l ) allDepLibDirsC | otherwise = allDepLibDirsC return libPaths where internal pkgid = pkgid == packageId (localPkgDescr lbi) -- 'canonicalizePath' fails on UNIX when the directory does not exists. -- So just don't canonicalize when it doesn't exist. canonicalizePathNoFail p = do exists <- doesDirectoryExist p if exists then canonicalizePath p else return p -- ----------------------------------------------------------------------------- -- Wrappers for a couple functions from InstallDirs -- |See 'InstallDirs.absoluteInstallDirs' absoluteInstallDirs :: PackageDescription -> LocalBuildInfo -> CopyDest -> InstallDirs FilePath absoluteInstallDirs pkg lbi copydest = InstallDirs.absoluteInstallDirs (packageId pkg) (pkgKey lbi) (compilerInfo (compiler lbi)) copydest (hostPlatform lbi) (installDirTemplates lbi) -- |See 'InstallDirs.prefixRelativeInstallDirs' prefixRelativeInstallDirs :: PackageId -> LocalBuildInfo -> InstallDirs (Maybe FilePath) prefixRelativeInstallDirs pkg_descr lbi = InstallDirs.prefixRelativeInstallDirs (packageId pkg_descr) (pkgKey lbi) (compilerInfo (compiler lbi)) (hostPlatform lbi) (installDirTemplates lbi) substPathTemplate :: PackageId -> LocalBuildInfo -> PathTemplate -> FilePath substPathTemplate pkgid lbi = fromPathTemplate . ( InstallDirs.substPathTemplate env ) where env = initialPathTemplateEnv pkgid (pkgKey lbi) (compilerInfo (compiler lbi)) (hostPlatform lbi) Cabal-1.22.5.0/Distribution/Simple/PackageIndex.hs0000644000000000000000000006421212627136220017724 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveGeneric #-} ----------------------------------------------------------------------------- -- | -- Module : Distribution.Simple.PackageIndex -- Copyright : (c) David Himmelstrup 2005, -- Bjorn Bringert 2007, -- Duncan Coutts 2008-2009 -- -- Maintainer : cabal-devel@haskell.org -- Portability : portable -- -- An index of packages. -- module Distribution.Simple.PackageIndex ( -- * Package index data type InstalledPackageIndex, PackageIndex, FakeMap, -- * Creating an index fromList, -- * Updates merge, insert, deleteInstalledPackageId, deleteSourcePackageId, deletePackageName, -- deleteDependency, -- * Queries -- ** Precise lookups lookupInstalledPackageId, lookupSourcePackageId, lookupPackageId, lookupPackageName, lookupDependency, -- ** Case-insensitive searches searchByName, SearchResult(..), searchByNameSubstring, -- ** Bulk queries allPackages, allPackagesByName, allPackagesBySourcePackageId, -- ** Special queries brokenPackages, dependencyClosure, reverseDependencyClosure, topologicalOrder, reverseTopologicalOrder, dependencyInconsistencies, dependencyCycles, dependencyGraph, moduleNameIndex, -- ** Variants of special queries supporting fake map fakeLookupInstalledPackageId, brokenPackages', dependencyClosure', reverseDependencyClosure', dependencyInconsistencies', dependencyCycles', dependencyGraph', ) where import Control.Exception (assert) import Data.Array ((!)) import qualified Data.Array as Array import Distribution.Compat.Binary (Binary) import qualified Data.Graph as Graph import Data.List as List ( null, foldl', sort , groupBy, sortBy, find, isInfixOf, nubBy, deleteBy, deleteFirstsBy ) #if __GLASGOW_HASKELL__ < 710 import Data.Monoid (Monoid(..)) #endif import Data.Map (Map) import qualified Data.Map as Map import Data.Maybe (isNothing, fromMaybe) import qualified Data.Tree as Tree import GHC.Generics (Generic) import Prelude hiding (lookup) import Distribution.Package ( PackageName(..), PackageId , Package(..), packageName, packageVersion , Dependency(Dependency)--, --PackageFixedDeps(..) , InstalledPackageId(..), PackageInstalled(..) ) import Distribution.ModuleName ( ModuleName ) import Distribution.InstalledPackageInfo ( InstalledPackageInfo ) import qualified Distribution.InstalledPackageInfo as IPI import Distribution.Version ( Version, withinRange ) import Distribution.Simple.Utils (lowercase, comparing, equating) -- Note [FakeMap] ----------------- -- We'd like to use the PackageIndex defined in this module for -- cabal-install's InstallPlan. However, at the moment, this -- data structure is indexed by InstalledPackageId, which we don't -- know until after we've compiled a package (whereas InstallPlan -- needs to store not-compiled packages in the index.) Eventually, -- an InstalledPackageId will be calculatable prior to actually -- building the package (making it something of a misnomer), but -- at the moment, the "fake installed package ID map" is a workaround -- to solve this problem while reusing PackageIndex. The basic idea -- is that, since we don't know what an InstalledPackageId is -- beforehand, we just fake up one based on the package ID (it only -- needs to be unique for the particular install plan), and fill -- it out with the actual generated InstalledPackageId after the -- package is successfully compiled. -- -- However, there is a problem: in the index there may be -- references using the old package ID, which are now dangling if -- we update the InstalledPackageId. We could map over the entire -- index to update these pointers as well (a costly operation), but -- instead, we've chosen to parametrize a variety of important functions -- by a FakeMap, which records what a fake installed package ID was -- actually resolved to post-compilation. If we do a lookup, we first -- check and see if it's a fake ID in the FakeMap. -- -- It's a bit grungy, but we expect this to only be temporary anyway. -- (Another possible workaround would have been to *not* update -- the installed package ID, but I decided this would be hard to -- understand.) -- | Map from fake installed package IDs to real ones. See Note [FakeMap] type FakeMap = Map InstalledPackageId InstalledPackageId -- | The collection of information about packages from one or more 'PackageDB's. -- These packages generally should have an instance of 'PackageInstalled' -- -- Packages are uniquely identified in by their 'InstalledPackageId', they can -- also be efficiently looked up by package name or by name and version. -- data PackageIndex a = PackageIndex -- The primary index. Each InstalledPackageInfo record is uniquely identified -- by its InstalledPackageId. -- !(Map InstalledPackageId a) -- This auxiliary index maps package names (case-sensitively) to all the -- versions and instances of that package. This allows us to find all -- versions satisfying a dependency. -- -- It is a three-level index. The first level is the package name, -- the second is the package version and the final level is instances -- of the same package version. These are unique by InstalledPackageId -- and are kept in preference order. -- -- FIXME: Clarify what "preference order" means. Check that this invariant is -- preserved. See #1463 for discussion. !(Map PackageName (Map Version [a])) deriving (Generic, Show, Read) instance Binary a => Binary (PackageIndex a) -- | The default package index which contains 'InstalledPackageInfo'. Normally -- use this. type InstalledPackageIndex = PackageIndex InstalledPackageInfo instance PackageInstalled a => Monoid (PackageIndex a) where mempty = PackageIndex Map.empty Map.empty mappend = merge --save one mappend with empty in the common case: mconcat [] = mempty mconcat xs = foldr1 mappend xs invariant :: PackageInstalled a => PackageIndex a -> Bool invariant (PackageIndex pids pnames) = map installedPackageId (Map.elems pids) == sort [ assert pinstOk (installedPackageId pinst) | (pname, pvers) <- Map.toList pnames , let pversOk = not (Map.null pvers) , (pver, pinsts) <- assert pversOk $ Map.toList pvers , let pinsts' = sortBy (comparing installedPackageId) pinsts pinstsOk = all (\g -> length g == 1) (groupBy (equating installedPackageId) pinsts') , pinst <- assert pinstsOk $ pinsts' , let pinstOk = packageName pinst == pname && packageVersion pinst == pver ] -- -- * Internal helpers -- mkPackageIndex :: PackageInstalled a => Map InstalledPackageId a -> Map PackageName (Map Version [a]) -> PackageIndex a mkPackageIndex pids pnames = assert (invariant index) index where index = PackageIndex pids pnames -- -- * Construction -- -- | Build an index out of a bunch of packages. -- -- If there are duplicates by 'InstalledPackageId' then later ones mask earlier -- ones. -- fromList :: PackageInstalled a => [a] -> PackageIndex a fromList pkgs = mkPackageIndex pids pnames where pids = Map.fromList [ (installedPackageId pkg, pkg) | pkg <- pkgs ] pnames = Map.fromList [ (packageName (head pkgsN), pvers) | pkgsN <- groupBy (equating packageName) . sortBy (comparing packageId) $ pkgs , let pvers = Map.fromList [ (packageVersion (head pkgsNV), nubBy (equating installedPackageId) (reverse pkgsNV)) | pkgsNV <- groupBy (equating packageVersion) pkgsN ] ] -- -- * Updates -- -- | Merge two indexes. -- -- Packages from the second mask packages from the first if they have the exact -- same 'InstalledPackageId'. -- -- For packages with the same source 'PackageId', packages from the second are -- \"preferred\" over those from the first. Being preferred means they are top -- result when we do a lookup by source 'PackageId'. This is the mechanism we -- use to prefer user packages over global packages. -- merge :: PackageInstalled a => PackageIndex a -> PackageIndex a -> PackageIndex a merge (PackageIndex pids1 pnames1) (PackageIndex pids2 pnames2) = mkPackageIndex (Map.unionWith (\_ y -> y) pids1 pids2) (Map.unionWith (Map.unionWith mergeBuckets) pnames1 pnames2) where -- Packages in the second list mask those in the first, however preferred -- packages go first in the list. mergeBuckets xs ys = ys ++ (xs \\ ys) (\\) = deleteFirstsBy (equating installedPackageId) -- | Inserts a single package into the index. -- -- This is equivalent to (but slightly quicker than) using 'mappend' or -- 'merge' with a singleton index. -- insert :: PackageInstalled a => a -> PackageIndex a -> PackageIndex a insert pkg (PackageIndex pids pnames) = mkPackageIndex pids' pnames' where pids' = Map.insert (installedPackageId pkg) pkg pids pnames' = insertPackageName pnames insertPackageName = Map.insertWith' (\_ -> insertPackageVersion) (packageName pkg) (Map.singleton (packageVersion pkg) [pkg]) insertPackageVersion = Map.insertWith' (\_ -> insertPackageInstance) (packageVersion pkg) [pkg] insertPackageInstance pkgs = pkg : deleteBy (equating installedPackageId) pkg pkgs -- | Removes a single installed package from the index. -- deleteInstalledPackageId :: PackageInstalled a => InstalledPackageId -> PackageIndex a -> PackageIndex a deleteInstalledPackageId ipkgid original@(PackageIndex pids pnames) = case Map.updateLookupWithKey (\_ _ -> Nothing) ipkgid pids of (Nothing, _) -> original (Just spkgid, pids') -> mkPackageIndex pids' (deletePkgName spkgid pnames) where deletePkgName spkgid = Map.update (deletePkgVersion spkgid) (packageName spkgid) deletePkgVersion spkgid = (\m -> if Map.null m then Nothing else Just m) . Map.update deletePkgInstance (packageVersion spkgid) deletePkgInstance = (\xs -> if List.null xs then Nothing else Just xs) . List.deleteBy (\_ pkg -> installedPackageId pkg == ipkgid) undefined -- | Removes all packages with this source 'PackageId' from the index. -- deleteSourcePackageId :: PackageInstalled a => PackageId -> PackageIndex a -> PackageIndex a deleteSourcePackageId pkgid original@(PackageIndex pids pnames) = case Map.lookup (packageName pkgid) pnames of Nothing -> original Just pvers -> case Map.lookup (packageVersion pkgid) pvers of Nothing -> original Just pkgs -> mkPackageIndex (foldl' (flip (Map.delete . installedPackageId)) pids pkgs) (deletePkgName pnames) where deletePkgName = Map.update deletePkgVersion (packageName pkgid) deletePkgVersion = (\m -> if Map.null m then Nothing else Just m) . Map.delete (packageVersion pkgid) -- | Removes all packages with this (case-sensitive) name from the index. -- deletePackageName :: PackageInstalled a => PackageName -> PackageIndex a -> PackageIndex a deletePackageName name original@(PackageIndex pids pnames) = case Map.lookup name pnames of Nothing -> original Just pvers -> mkPackageIndex (foldl' (flip (Map.delete . installedPackageId)) pids (concat (Map.elems pvers))) (Map.delete name pnames) {- -- | Removes all packages satisfying this dependency from the index. -- deleteDependency :: Dependency -> PackageIndex -> PackageIndex deleteDependency (Dependency name verstionRange) = delete' name (\pkg -> packageVersion pkg `withinRange` verstionRange) -} -- -- * Bulk queries -- -- | Get all the packages from the index. -- allPackages :: PackageIndex a -> [a] allPackages (PackageIndex pids _) = Map.elems pids -- | Get all the packages from the index. -- -- They are grouped by package name (case-sensitively). -- allPackagesByName :: PackageIndex a -> [(PackageName, [a])] allPackagesByName (PackageIndex _ pnames) = [ (pkgname, concat (Map.elems pvers)) | (pkgname, pvers) <- Map.toList pnames ] -- | Get all the packages from the index. -- -- They are grouped by source package id (package name and version). -- allPackagesBySourcePackageId :: PackageInstalled a => PackageIndex a -> [(PackageId, [a])] allPackagesBySourcePackageId (PackageIndex _ pnames) = [ (packageId ipkg, ipkgs) | pvers <- Map.elems pnames , ipkgs@(ipkg:_) <- Map.elems pvers ] -- -- * Lookups -- -- | Does a lookup by source package id (name & version). -- -- Since multiple package DBs mask each other by 'InstalledPackageId', -- then we get back at most one package. -- lookupInstalledPackageId :: PackageInstalled a => PackageIndex a -> InstalledPackageId -> Maybe a lookupInstalledPackageId (PackageIndex pids _) pid = Map.lookup pid pids -- | Does a lookup by source package id (name & version). -- -- There can be multiple installed packages with the same source 'PackageId' -- but different 'InstalledPackageId'. They are returned in order of -- preference, with the most preferred first. -- lookupSourcePackageId :: PackageInstalled a => PackageIndex a -> PackageId -> [a] lookupSourcePackageId (PackageIndex _ pnames) pkgid = case Map.lookup (packageName pkgid) pnames of Nothing -> [] Just pvers -> case Map.lookup (packageVersion pkgid) pvers of Nothing -> [] Just pkgs -> pkgs -- in preference order -- | Convenient alias of 'lookupSourcePackageId', but assuming only -- one package per package ID. lookupPackageId :: PackageInstalled a => PackageIndex a -> PackageId -> Maybe a lookupPackageId index pkgid = case lookupSourcePackageId index pkgid of [] -> Nothing [pkg] -> Just pkg _ -> error "Distribution.Simple.PackageIndex: multiple matches found" -- | Does a lookup by source package name. -- lookupPackageName :: PackageInstalled a => PackageIndex a -> PackageName -> [(Version, [a])] lookupPackageName (PackageIndex _ pnames) name = case Map.lookup name pnames of Nothing -> [] Just pvers -> Map.toList pvers -- | Does a lookup by source package name and a range of versions. -- -- We get back any number of versions of the specified package name, all -- satisfying the version range constraint. -- lookupDependency :: PackageInstalled a => PackageIndex a -> Dependency -> [(Version, [a])] lookupDependency (PackageIndex _ pnames) (Dependency name versionRange) = case Map.lookup name pnames of Nothing -> [] Just pvers -> [ entry | entry@(ver, _) <- Map.toList pvers , ver `withinRange` versionRange ] -- -- * Case insensitive name lookups -- -- | Does a case-insensitive search by package name. -- -- If there is only one package that compares case-insensitively to this name -- then the search is unambiguous and we get back all versions of that package. -- If several match case-insensitively but one matches exactly then it is also -- unambiguous. -- -- If however several match case-insensitively and none match exactly then we -- have an ambiguous result, and we get back all the versions of all the -- packages. The list of ambiguous results is split by exact package name. So -- it is a non-empty list of non-empty lists. -- searchByName :: PackageInstalled a => PackageIndex a -> String -> SearchResult [a] searchByName (PackageIndex _ pnames) name = case [ pkgs | pkgs@(PackageName name',_) <- Map.toList pnames , lowercase name' == lname ] of [] -> None [(_,pvers)] -> Unambiguous (concat (Map.elems pvers)) pkgss -> case find ((PackageName name==) . fst) pkgss of Just (_,pvers) -> Unambiguous (concat (Map.elems pvers)) Nothing -> Ambiguous (map (concat . Map.elems . snd) pkgss) where lname = lowercase name data SearchResult a = None | Unambiguous a | Ambiguous [a] -- | Does a case-insensitive substring search by package name. -- -- That is, all packages that contain the given string in their name. -- searchByNameSubstring :: PackageInstalled a => PackageIndex a -> String -> [a] searchByNameSubstring (PackageIndex _ pnames) searchterm = [ pkg | (PackageName name, pvers) <- Map.toList pnames , lsearchterm `isInfixOf` lowercase name , pkgs <- Map.elems pvers , pkg <- pkgs ] where lsearchterm = lowercase searchterm -- -- * Special queries -- -- None of the stuff below depends on the internal representation of the index. -- -- | Find if there are any cycles in the dependency graph. If there are no -- cycles the result is @[]@. -- -- This actually computes the strongly connected components. So it gives us a -- list of groups of packages where within each group they all depend on each -- other, directly or indirectly. -- dependencyCycles :: PackageInstalled a => PackageIndex a -> [[a]] dependencyCycles = dependencyCycles' Map.empty -- | Variant of 'dependencyCycles' which accepts a 'FakeMap'. See Note [FakeMap]. dependencyCycles' :: PackageInstalled a => FakeMap -> PackageIndex a -> [[a]] dependencyCycles' fakeMap index = [ vs | Graph.CyclicSCC vs <- Graph.stronglyConnComp adjacencyList ] where adjacencyList = [ (pkg, installedPackageId pkg, fakeInstalledDepends fakeMap pkg) | pkg <- allPackages index ] -- | All packages that have immediate dependencies that are not in the index. -- -- Returns such packages along with the dependencies that they're missing. -- brokenPackages :: PackageInstalled a => PackageIndex a -> [(a, [InstalledPackageId])] brokenPackages = brokenPackages' Map.empty -- | Variant of 'brokenPackages' which accepts a 'FakeMap'. See Note [FakeMap]. brokenPackages' :: PackageInstalled a => FakeMap -> PackageIndex a -> [(a, [InstalledPackageId])] brokenPackages' fakeMap index = [ (pkg, missing) | pkg <- allPackages index , let missing = [ pkg' | pkg' <- installedDepends pkg , isNothing (fakeLookupInstalledPackageId fakeMap index pkg') ] , not (null missing) ] -- | Variant of 'lookupInstalledPackageId' which accepts a 'FakeMap'. See Note [FakeMap]. fakeLookupInstalledPackageId :: PackageInstalled a => FakeMap -> PackageIndex a -> InstalledPackageId -> Maybe a fakeLookupInstalledPackageId fakeMap index pkg = lookupInstalledPackageId index (Map.findWithDefault pkg pkg fakeMap) -- | Tries to take the transitive closure of the package dependencies. -- -- If the transitive closure is complete then it returns that subset of the -- index. Otherwise it returns the broken packages as in 'brokenPackages'. -- -- * Note that if the result is @Right []@ it is because at least one of -- the original given 'PackageId's do not occur in the index. -- dependencyClosure :: PackageInstalled a => PackageIndex a -> [InstalledPackageId] -> Either (PackageIndex a) [(a, [InstalledPackageId])] dependencyClosure = dependencyClosure' Map.empty -- | Variant of 'dependencyClosure' which accepts a 'FakeMap'. See Note [FakeMap]. dependencyClosure' :: PackageInstalled a => FakeMap -> PackageIndex a -> [InstalledPackageId] -> Either (PackageIndex a) [(a, [InstalledPackageId])] dependencyClosure' fakeMap index pkgids0 = case closure mempty [] pkgids0 of (completed, []) -> Left completed (completed, _) -> Right (brokenPackages completed) where closure completed failed [] = (completed, failed) closure completed failed (pkgid:pkgids) = case fakeLookupInstalledPackageId fakeMap index pkgid of Nothing -> closure completed (pkgid:failed) pkgids Just pkg -> case fakeLookupInstalledPackageId fakeMap completed (installedPackageId pkg) of Just _ -> closure completed failed pkgids Nothing -> closure completed' failed pkgids' where completed' = insert pkg completed pkgids' = installedDepends pkg ++ pkgids -- | Takes the transitive closure of the packages reverse dependencies. -- -- * The given 'PackageId's must be in the index. -- reverseDependencyClosure :: PackageInstalled a => PackageIndex a -> [InstalledPackageId] -> [a] reverseDependencyClosure = reverseDependencyClosure' Map.empty -- | Variant of 'reverseDependencyClosure' which accepts a 'FakeMap'. See Note [FakeMap]. reverseDependencyClosure' :: PackageInstalled a => FakeMap -> PackageIndex a -> [InstalledPackageId] -> [a] reverseDependencyClosure' fakeMap index = map vertexToPkg . concatMap Tree.flatten . Graph.dfs reverseDepGraph . map (fromMaybe noSuchPkgId . pkgIdToVertex) where (depGraph, vertexToPkg, pkgIdToVertex) = dependencyGraph' fakeMap index reverseDepGraph = Graph.transposeG depGraph noSuchPkgId = error "reverseDependencyClosure: package is not in the graph" topologicalOrder :: PackageInstalled a => PackageIndex a -> [a] topologicalOrder index = map toPkgId . Graph.topSort $ graph where (graph, toPkgId, _) = dependencyGraph index reverseTopologicalOrder :: PackageInstalled a => PackageIndex a -> [a] reverseTopologicalOrder index = map toPkgId . Graph.topSort . Graph.transposeG $ graph where (graph, toPkgId, _) = dependencyGraph index -- | Builds a graph of the package dependencies. -- -- Dependencies on other packages that are not in the index are discarded. -- You can check if there are any such dependencies with 'brokenPackages'. -- dependencyGraph :: PackageInstalled a => PackageIndex a -> (Graph.Graph, Graph.Vertex -> a, InstalledPackageId -> Maybe Graph.Vertex) dependencyGraph = dependencyGraph' Map.empty -- | Variant of 'dependencyGraph' which accepts a 'FakeMap'. See Note [FakeMap]. dependencyGraph' :: PackageInstalled a => FakeMap -> PackageIndex a -> (Graph.Graph, Graph.Vertex -> a, InstalledPackageId -> Maybe Graph.Vertex) dependencyGraph' fakeMap index = (graph, vertex_to_pkg, id_to_vertex) where graph = Array.listArray bounds [ [ v | Just v <- map id_to_vertex (installedDepends pkg) ] | pkg <- pkgs ] pkgs = sortBy (comparing packageId) (allPackages index) vertices = zip (map installedPackageId pkgs) [0..] vertex_map = Map.fromList vertices id_to_vertex pid = Map.lookup (Map.findWithDefault pid pid fakeMap) vertex_map vertex_to_pkg vertex = pkgTable ! vertex pkgTable = Array.listArray bounds pkgs topBound = length pkgs - 1 bounds = (0, topBound) -- | Given a package index where we assume we want to use all the packages -- (use 'dependencyClosure' if you need to get such a index subset) find out -- if the dependencies within it use consistent versions of each package. -- Return all cases where multiple packages depend on different versions of -- some other package. -- -- Each element in the result is a package name along with the packages that -- depend on it and the versions they require. These are guaranteed to be -- distinct. -- dependencyInconsistencies :: PackageInstalled a => PackageIndex a -> [(PackageName, [(PackageId, Version)])] dependencyInconsistencies = dependencyInconsistencies' Map.empty -- | Variant of 'dependencyInconsistencies' which accepts a 'FakeMap'. See Note [FakeMap]. dependencyInconsistencies' :: PackageInstalled a => FakeMap -> PackageIndex a -> [(PackageName, [(PackageId, Version)])] dependencyInconsistencies' fakeMap index = [ (name, [ (pid,packageVersion dep) | (dep,pids) <- uses, pid <- pids]) | (name, ipid_map) <- Map.toList inverseIndex , let uses = Map.elems ipid_map , reallyIsInconsistent (map fst uses) ] where -- for each PackageName, -- for each package with that name, -- the InstalledPackageInfo and the package Ids of packages -- that depend on it. inverseIndex = Map.fromListWith (Map.unionWith (\(a,b) (_,b') -> (a,b++b'))) [ (packageName dep, Map.fromList [(ipid,(dep,[packageId pkg]))]) | pkg <- allPackages index , ipid <- fakeInstalledDepends fakeMap pkg , Just dep <- [fakeLookupInstalledPackageId fakeMap index ipid] ] reallyIsInconsistent :: PackageInstalled a => [a] -> Bool reallyIsInconsistent [] = False reallyIsInconsistent [_p] = False reallyIsInconsistent [p1, p2] = let pid1 = installedPackageId p1 pid2 = installedPackageId p2 in Map.findWithDefault pid1 pid1 fakeMap `notElem` fakeInstalledDepends fakeMap p2 && Map.findWithDefault pid2 pid2 fakeMap `notElem` fakeInstalledDepends fakeMap p1 reallyIsInconsistent _ = True -- | Variant of 'installedDepends' which accepts a 'FakeMap'. See Note [FakeMap]. fakeInstalledDepends :: PackageInstalled a => FakeMap -> a -> [InstalledPackageId] fakeInstalledDepends fakeMap = map (\pid -> Map.findWithDefault pid pid fakeMap) . installedDepends -- | A rough approximation of GHC's module finder, takes a 'InstalledPackageIndex' and -- turns it into a map from module names to their source packages. It's used to -- initialize the @build-deps@ field in @cabal init@. moduleNameIndex :: InstalledPackageIndex -> Map ModuleName [InstalledPackageInfo] moduleNameIndex index = Map.fromListWith (++) $ do pkg <- allPackages index IPI.ExposedModule m reexport _ <- IPI.exposedModules pkg case reexport of Nothing -> return (m, [pkg]) Just (IPI.OriginalModule _ m') | m == m' -> [] | otherwise -> return (m', [pkg]) -- The heuristic is this: we want to prefer the original package -- which originally exported a module. However, if a reexport -- also *renamed* the module (m /= m'), then we have to use the -- downstream package, since the upstream package has the wrong -- module name! Cabal-1.22.5.0/Distribution/Simple/PreProcess.hs0000644000000000000000000006657212627136220017501 0ustar0000000000000000----------------------------------------------------------------------------- -- | -- Module : Distribution.Simple.PreProcess -- Copyright : (c) 2003-2005, Isaac Jones, Malcolm Wallace -- License : BSD3 -- -- Maintainer : cabal-devel@haskell.org -- Portability : portable -- -- This defines a 'PreProcessor' abstraction which represents a pre-processor -- that can transform one kind of file into another. There is also a -- 'PPSuffixHandler' which is a combination of a file extension and a function -- for configuring a 'PreProcessor'. It defines a bunch of known built-in -- preprocessors like @cpp@, @cpphs@, @c2hs@, @hsc2hs@, @happy@, @alex@ etc and -- lists them in 'knownSuffixHandlers'. On top of this it provides a function -- for actually preprocessing some sources given a bunch of known suffix -- handlers. This module is not as good as it could be, it could really do with -- a rewrite to address some of the problems we have with pre-processors. module Distribution.Simple.PreProcess (preprocessComponent, knownSuffixHandlers, ppSuffixes, PPSuffixHandler, PreProcessor(..), mkSimplePreProcessor, runSimplePreProcessor, ppCpp, ppCpp', ppGreenCard, ppC2hs, ppHsc2hs, ppHappy, ppAlex, ppUnlit, platformDefines ) where import Control.Monad import Distribution.Simple.PreProcess.Unlit (unlit) import Distribution.Package ( Package(..), PackageName(..) ) import qualified Distribution.ModuleName as ModuleName import Distribution.PackageDescription as PD ( PackageDescription(..), BuildInfo(..) , Executable(..) , Library(..), libModules , TestSuite(..), testModules , TestSuiteInterface(..) , Benchmark(..), benchmarkModules, BenchmarkInterface(..) ) import qualified Distribution.InstalledPackageInfo as Installed ( InstalledPackageInfo_(..) ) import qualified Distribution.Simple.PackageIndex as PackageIndex import Distribution.Simple.CCompiler ( cSourceExtensions ) import Distribution.Simple.Compiler ( CompilerFlavor(..) , compilerFlavor, compilerCompatVersion, compilerVersion ) import Distribution.Simple.LocalBuildInfo ( LocalBuildInfo(..), Component(..) ) import Distribution.Simple.BuildPaths (autogenModulesDir,cppHeaderName) import Distribution.Simple.Utils ( createDirectoryIfMissingVerbose, withUTF8FileContents, writeUTF8File , die, setupMessage, intercalate, copyFileVerbose, moreRecentFile , findFileWithExtension, findFileWithExtension' ) import Distribution.Simple.Program ( Program(..), ConfiguredProgram(..), programPath , requireProgram, requireProgramVersion , rawSystemProgramConf, rawSystemProgram , greencardProgram, cpphsProgram, hsc2hsProgram, c2hsProgram , happyProgram, alexProgram, ghcProgram, ghcjsProgram, gccProgram ) import Distribution.Simple.Test.LibV09 ( writeSimpleTestStub, stubFilePath, stubName ) import Distribution.System ( OS(..), buildOS, Arch(..), Platform(..) ) import Distribution.Text import Distribution.Version ( Version(..), anyVersion, orLaterVersion ) import Distribution.Verbosity import Data.Maybe (fromMaybe) import Data.List (nub) import System.Directory (doesFileExist) import System.Info (os, arch) import System.FilePath (splitExtension, dropExtensions, (), (<.>), takeDirectory, normalise, replaceExtension) -- |The interface to a preprocessor, which may be implemented using an -- external program, but need not be. The arguments are the name of -- the input file, the name of the output file and a verbosity level. -- Here is a simple example that merely prepends a comment to the given -- source file: -- -- > ppTestHandler :: PreProcessor -- > ppTestHandler = -- > PreProcessor { -- > platformIndependent = True, -- > runPreProcessor = mkSimplePreProcessor $ \inFile outFile verbosity -> -- > do info verbosity (inFile++" has been preprocessed to "++outFile) -- > stuff <- readFile inFile -- > writeFile outFile ("-- preprocessed as a test\n\n" ++ stuff) -- > return ExitSuccess -- -- We split the input and output file names into a base directory and the -- rest of the file name. The input base dir is the path in the list of search -- dirs that this file was found in. The output base dir is the build dir where -- all the generated source files are put. -- -- The reason for splitting it up this way is that some pre-processors don't -- simply generate one output .hs file from one input file but have -- dependencies on other generated files (notably c2hs, where building one -- .hs file may require reading other .chi files, and then compiling the .hs -- file may require reading a generated .h file). In these cases the generated -- files need to embed relative path names to each other (eg the generated .hs -- file mentions the .h file in the FFI imports). This path must be relative to -- the base directory where the generated files are located, it cannot be -- relative to the top level of the build tree because the compilers do not -- look for .h files relative to there, ie we do not use \"-I .\", instead we -- use \"-I dist\/build\" (or whatever dist dir has been set by the user) -- -- Most pre-processors do not care of course, so mkSimplePreProcessor and -- runSimplePreProcessor functions handle the simple case. -- data PreProcessor = PreProcessor { -- Is the output of the pre-processor platform independent? eg happy output -- is portable haskell but c2hs's output is platform dependent. -- This matters since only platform independent generated code can be -- inlcuded into a source tarball. platformIndependent :: Bool, -- TODO: deal with pre-processors that have implementaion dependent output -- eg alex and happy have --ghc flags. However we can't really inlcude -- ghc-specific code into supposedly portable source tarballs. runPreProcessor :: (FilePath, FilePath) -- Location of the source file relative to a base dir -> (FilePath, FilePath) -- Output file name, relative to an output base dir -> Verbosity -- verbosity -> IO () -- Should exit if the preprocessor fails } mkSimplePreProcessor :: (FilePath -> FilePath -> Verbosity -> IO ()) -> (FilePath, FilePath) -> (FilePath, FilePath) -> Verbosity -> IO () mkSimplePreProcessor simplePP (inBaseDir, inRelativeFile) (outBaseDir, outRelativeFile) verbosity = simplePP inFile outFile verbosity where inFile = normalise (inBaseDir inRelativeFile) outFile = normalise (outBaseDir outRelativeFile) runSimplePreProcessor :: PreProcessor -> FilePath -> FilePath -> Verbosity -> IO () runSimplePreProcessor pp inFile outFile verbosity = runPreProcessor pp (".", inFile) (".", outFile) verbosity -- |A preprocessor for turning non-Haskell files with the given extension -- into plain Haskell source files. type PPSuffixHandler = (String, BuildInfo -> LocalBuildInfo -> PreProcessor) -- | Apply preprocessors to the sources from 'hsSourceDirs' for a given -- component (lib, exe, or test suite). preprocessComponent :: PackageDescription -> Component -> LocalBuildInfo -> Bool -> Verbosity -> [PPSuffixHandler] -> IO () preprocessComponent pd comp lbi isSrcDist verbosity handlers = case comp of (CLib lib@Library{ libBuildInfo = bi }) -> do let dirs = hsSourceDirs bi ++ [autogenModulesDir lbi] setupMessage verbosity "Preprocessing library" (packageId pd) forM_ (map ModuleName.toFilePath $ libModules lib) $ pre dirs (buildDir lbi) (localHandlers bi) (CExe exe@Executable { buildInfo = bi, exeName = nm }) -> do let exeDir = buildDir lbi nm nm ++ "-tmp" dirs = hsSourceDirs bi ++ [autogenModulesDir lbi] setupMessage verbosity ("Preprocessing executable '" ++ nm ++ "' for") (packageId pd) forM_ (map ModuleName.toFilePath $ otherModules bi) $ pre dirs exeDir (localHandlers bi) pre (hsSourceDirs bi) exeDir (localHandlers bi) $ dropExtensions (modulePath exe) CTest test@TestSuite{ testName = nm } -> do setupMessage verbosity ("Preprocessing test suite '" ++ nm ++ "' for") (packageId pd) case testInterface test of TestSuiteExeV10 _ f -> preProcessTest test f $ buildDir lbi testName test testName test ++ "-tmp" TestSuiteLibV09 _ _ -> do let testDir = buildDir lbi stubName test stubName test ++ "-tmp" writeSimpleTestStub test testDir preProcessTest test (stubFilePath test) testDir TestSuiteUnsupported tt -> die $ "No support for preprocessing test " ++ "suite type " ++ display tt CBench bm@Benchmark{ benchmarkName = nm } -> do setupMessage verbosity ("Preprocessing benchmark '" ++ nm ++ "' for") (packageId pd) case benchmarkInterface bm of BenchmarkExeV10 _ f -> preProcessBench bm f $ buildDir lbi benchmarkName bm benchmarkName bm ++ "-tmp" BenchmarkUnsupported tt -> die $ "No support for preprocessing benchmark " ++ "type " ++ display tt where builtinHaskellSuffixes = ["hs", "lhs", "hsig", "lhsig"] builtinCSuffixes = cSourceExtensions builtinSuffixes = builtinHaskellSuffixes ++ builtinCSuffixes localHandlers bi = [(ext, h bi lbi) | (ext, h) <- handlers] pre dirs dir lhndlrs fp = preprocessFile dirs dir isSrcDist fp verbosity builtinSuffixes lhndlrs preProcessTest test = preProcessComponent (testBuildInfo test) (testModules test) preProcessBench bm = preProcessComponent (benchmarkBuildInfo bm) (benchmarkModules bm) preProcessComponent bi modules exePath dir = do let biHandlers = localHandlers bi sourceDirs = hsSourceDirs bi ++ [ autogenModulesDir lbi ] sequence_ [ preprocessFile sourceDirs dir isSrcDist (ModuleName.toFilePath modu) verbosity builtinSuffixes biHandlers | modu <- modules ] preprocessFile (dir : (hsSourceDirs bi)) dir isSrcDist (dropExtensions $ exePath) verbosity builtinSuffixes biHandlers --TODO: try to list all the modules that could not be found -- not just the first one. It's annoying and slow due to the need -- to reconfigure after editing the .cabal file each time. -- |Find the first extension of the file that exists, and preprocess it -- if required. preprocessFile :: [FilePath] -- ^source directories -> FilePath -- ^build directory -> Bool -- ^preprocess for sdist -> FilePath -- ^module file name -> Verbosity -- ^verbosity -> [String] -- ^builtin suffixes -> [(String, PreProcessor)] -- ^possible preprocessors -> IO () preprocessFile searchLoc buildLoc forSDist baseFile verbosity builtinSuffixes handlers = do -- look for files in the various source dirs with this module name -- and a file extension of a known preprocessor psrcFiles <- findFileWithExtension' (map fst handlers) searchLoc baseFile case psrcFiles of -- no preprocessor file exists, look for an ordinary source file -- just to make sure one actually exists at all for this module. -- Note: by looking in the target/output build dir too, we allow -- source files to appear magically in the target build dir without -- any corresponding "real" source file. This lets custom Setup.hs -- files generate source modules directly into the build dir without -- the rest of the build system being aware of it (somewhat dodgy) Nothing -> do bsrcFiles <- findFileWithExtension builtinSuffixes (buildLoc : searchLoc) baseFile case bsrcFiles of Nothing -> die $ "can't find source for " ++ baseFile ++ " in " ++ intercalate ", " searchLoc _ -> return () -- found a pre-processable file in one of the source dirs Just (psrcLoc, psrcRelFile) -> do let (srcStem, ext) = splitExtension psrcRelFile psrcFile = psrcLoc psrcRelFile pp = fromMaybe (error "Internal error in preProcess module: Just expected") (lookup (tailNotNull ext) handlers) -- Preprocessing files for 'sdist' is different from preprocessing -- for 'build'. When preprocessing for sdist we preprocess to -- avoid that the user has to have the preprocessors available. -- ATM, we don't have a way to specify which files are to be -- preprocessed and which not, so for sdist we only process -- platform independent files and put them into the 'buildLoc' -- (which we assume is set to the temp. directory that will become -- the tarball). --TODO: eliminate sdist variant, just supply different handlers when (not forSDist || forSDist && platformIndependent pp) $ do -- look for existing pre-processed source file in the dest dir to -- see if we really have to re-run the preprocessor. ppsrcFiles <- findFileWithExtension builtinSuffixes [buildLoc] baseFile recomp <- case ppsrcFiles of Nothing -> return True Just ppsrcFile -> psrcFile `moreRecentFile` ppsrcFile when recomp $ do let destDir = buildLoc dirName srcStem createDirectoryIfMissingVerbose verbosity True destDir runPreProcessorWithHsBootHack pp (psrcLoc, psrcRelFile) (buildLoc, srcStem <.> "hs") where dirName = takeDirectory tailNotNull [] = [] tailNotNull x = tail x -- FIXME: This is a somewhat nasty hack. GHC requires that hs-boot files -- be in the same place as the hs files, so if we put the hs file in dist/ -- then we need to copy the hs-boot file there too. This should probably be -- done another way. Possibly we should also be looking for .lhs-boot -- files, but I think that preprocessors only produce .hs files. runPreProcessorWithHsBootHack pp (inBaseDir, inRelativeFile) (outBaseDir, outRelativeFile) = do runPreProcessor pp (inBaseDir, inRelativeFile) (outBaseDir, outRelativeFile) verbosity exists <- doesFileExist inBoot when exists $ copyFileVerbose verbosity inBoot outBoot where inBoot = replaceExtension inFile "hs-boot" outBoot = replaceExtension outFile "hs-boot" inFile = normalise (inBaseDir inRelativeFile) outFile = normalise (outBaseDir outRelativeFile) -- ------------------------------------------------------------ -- * known preprocessors -- ------------------------------------------------------------ ppGreenCard :: BuildInfo -> LocalBuildInfo -> PreProcessor ppGreenCard _ lbi = PreProcessor { platformIndependent = False, runPreProcessor = mkSimplePreProcessor $ \inFile outFile verbosity -> rawSystemProgramConf verbosity greencardProgram (withPrograms lbi) (["-tffi", "-o" ++ outFile, inFile]) } -- This one is useful for preprocessors that can't handle literate source. -- We also need a way to chain preprocessors. ppUnlit :: PreProcessor ppUnlit = PreProcessor { platformIndependent = True, runPreProcessor = mkSimplePreProcessor $ \inFile outFile _verbosity -> withUTF8FileContents inFile $ \contents -> either (writeUTF8File outFile) die (unlit inFile contents) } ppCpp :: BuildInfo -> LocalBuildInfo -> PreProcessor ppCpp = ppCpp' [] ppCpp' :: [String] -> BuildInfo -> LocalBuildInfo -> PreProcessor ppCpp' extraArgs bi lbi = case compilerFlavor (compiler lbi) of GHC -> ppGhcCpp ghcProgram (>= Version [6,6] []) args bi lbi GHCJS -> ppGhcCpp ghcjsProgram (const True) args bi lbi _ -> ppCpphs args bi lbi where cppArgs = getCppOptions bi lbi args = cppArgs ++ extraArgs ppGhcCpp :: Program -> (Version -> Bool) -> [String] -> BuildInfo -> LocalBuildInfo -> PreProcessor ppGhcCpp program xHs extraArgs _bi lbi = PreProcessor { platformIndependent = False, runPreProcessor = mkSimplePreProcessor $ \inFile outFile verbosity -> do (prog, version, _) <- requireProgramVersion verbosity program anyVersion (withPrograms lbi) rawSystemProgram verbosity prog $ ["-E", "-cpp"] -- This is a bit of an ugly hack. We're going to -- unlit the file ourselves later on if appropriate, -- so we need GHC not to unlit it now or it'll get -- double-unlitted. In the future we might switch to -- using cpphs --unlit instead. ++ (if xHs version then ["-x", "hs"] else []) ++ [ "-optP-include", "-optP"++ (autogenModulesDir lbi cppHeaderName) ] ++ ["-o", outFile, inFile] ++ extraArgs } ppCpphs :: [String] -> BuildInfo -> LocalBuildInfo -> PreProcessor ppCpphs extraArgs _bi lbi = PreProcessor { platformIndependent = False, runPreProcessor = mkSimplePreProcessor $ \inFile outFile verbosity -> do (cpphsProg, cpphsVersion, _) <- requireProgramVersion verbosity cpphsProgram anyVersion (withPrograms lbi) rawSystemProgram verbosity cpphsProg $ ("-O" ++ outFile) : inFile : "--noline" : "--strip" : (if cpphsVersion >= Version [1,6] [] then ["--include="++ (autogenModulesDir lbi cppHeaderName)] else []) ++ extraArgs } ppHsc2hs :: BuildInfo -> LocalBuildInfo -> PreProcessor ppHsc2hs bi lbi = PreProcessor { platformIndependent = False, runPreProcessor = mkSimplePreProcessor $ \inFile outFile verbosity -> do (gccProg, _) <- requireProgram verbosity gccProgram (withPrograms lbi) rawSystemProgramConf verbosity hsc2hsProgram (withPrograms lbi) $ [ "--cc=" ++ programPath gccProg , "--ld=" ++ programPath gccProg ] -- Additional gcc options ++ [ "--cflag=" ++ opt | opt <- programDefaultArgs gccProg ++ programOverrideArgs gccProg ] ++ [ "--lflag=" ++ opt | opt <- programDefaultArgs gccProg ++ programOverrideArgs gccProg ] -- OSX frameworks: ++ [ what ++ "=-F" ++ opt | isOSX , opt <- nub (concatMap Installed.frameworkDirs pkgs) , what <- ["--cflag", "--lflag"] ] ++ [ "--lflag=" ++ arg | isOSX , opt <- PD.frameworks bi ++ concatMap Installed.frameworks pkgs , arg <- ["-framework", opt] ] -- Note that on ELF systems, wherever we use -L, we must also use -R -- because presumably that -L dir is not on the normal path for the -- system's dynamic linker. This is needed because hsc2hs works by -- compiling a C program and then running it. ++ [ "--cflag=" ++ opt | opt <- platformDefines lbi ] -- Options from the current package: ++ [ "--cflag=-I" ++ dir | dir <- PD.includeDirs bi ] ++ [ "--cflag=" ++ opt | opt <- PD.ccOptions bi ++ PD.cppOptions bi ] ++ [ "--cflag=" ++ opt | opt <- [ "-I" ++ autogenModulesDir lbi, "-include", autogenModulesDir lbi cppHeaderName ] ] ++ [ "--lflag=-L" ++ opt | opt <- PD.extraLibDirs bi ] ++ [ "--lflag=-Wl,-R," ++ opt | isELF , opt <- PD.extraLibDirs bi ] ++ [ "--lflag=-l" ++ opt | opt <- PD.extraLibs bi ] ++ [ "--lflag=" ++ opt | opt <- PD.ldOptions bi ] -- Options from dependent packages ++ [ "--cflag=" ++ opt | pkg <- pkgs , opt <- [ "-I" ++ opt | opt <- Installed.includeDirs pkg ] ++ [ opt | opt <- Installed.ccOptions pkg ] ] ++ [ "--lflag=" ++ opt | pkg <- pkgs , opt <- [ "-L" ++ opt | opt <- Installed.libraryDirs pkg ] ++ [ "-Wl,-R," ++ opt | isELF , opt <- Installed.libraryDirs pkg ] ++ [ "-l" ++ opt | opt <- Installed.extraLibraries pkg ] ++ [ opt | opt <- Installed.ldOptions pkg ] ] ++ ["-o", outFile, inFile] } where pkgs = PackageIndex.topologicalOrder (packageHacks (installedPkgs lbi)) isOSX = case buildOS of OSX -> True; _ -> False isELF = case buildOS of OSX -> False; Windows -> False; _ -> True; packageHacks = case compilerFlavor (compiler lbi) of GHC -> hackRtsPackage GHCJS -> hackRtsPackage _ -> id -- We don't link in the actual Haskell libraries of our dependencies, so -- the -u flags in the ldOptions of the rts package mean linking fails on -- OS X (it's ld is a tad stricter than gnu ld). Thus we remove the -- ldOptions for GHC's rts package: hackRtsPackage index = case PackageIndex.lookupPackageName index (PackageName "rts") of [(_, [rts])] -> PackageIndex.insert rts { Installed.ldOptions = [] } index _ -> error "No (or multiple) ghc rts package is registered!!" ppC2hs :: BuildInfo -> LocalBuildInfo -> PreProcessor ppC2hs bi lbi = PreProcessor { platformIndependent = False, runPreProcessor = \(inBaseDir, inRelativeFile) (outBaseDir, outRelativeFile) verbosity -> do (c2hsProg, _, _) <- requireProgramVersion verbosity c2hsProgram (orLaterVersion (Version [0,15] [])) (withPrograms lbi) (gccProg, _) <- requireProgram verbosity gccProgram (withPrograms lbi) rawSystemProgram verbosity c2hsProg $ -- Options from the current package: [ "--cpp=" ++ programPath gccProg, "--cppopts=-E" ] ++ [ "--cppopts=" ++ opt | opt <- getCppOptions bi lbi ] ++ [ "--include=" ++ outBaseDir ] -- Options from dependent packages ++ [ "--cppopts=" ++ opt | pkg <- pkgs , opt <- [ "-I" ++ opt | opt <- Installed.includeDirs pkg ] ++ [ opt | opt@('-':c:_) <- Installed.ccOptions pkg , c `elem` "DIU" ] ] --TODO: install .chi files for packages, so we can --include -- those dirs here, for the dependencies -- input and output files ++ [ "--output-dir=" ++ outBaseDir , "--output=" ++ outRelativeFile , inBaseDir inRelativeFile ] } where pkgs = PackageIndex.topologicalOrder (installedPkgs lbi) --TODO: perhaps use this with hsc2hs too --TODO: remove cc-options from cpphs for cabal-version: >= 1.10 getCppOptions :: BuildInfo -> LocalBuildInfo -> [String] getCppOptions bi lbi = platformDefines lbi ++ cppOptions bi ++ ["-I" ++ dir | dir <- PD.includeDirs bi] ++ [opt | opt@('-':c:_) <- PD.ccOptions bi, c `elem` "DIU"] platformDefines :: LocalBuildInfo -> [String] platformDefines lbi = case compilerFlavor comp of GHC -> ["-D__GLASGOW_HASKELL__=" ++ versionInt version] ++ ["-D" ++ os ++ "_BUILD_OS=1"] ++ ["-D" ++ arch ++ "_BUILD_ARCH=1"] ++ map (\os' -> "-D" ++ os' ++ "_HOST_OS=1") osStr ++ map (\arch' -> "-D" ++ arch' ++ "_HOST_ARCH=1") archStr GHCJS -> compatGlasgowHaskell ++ ["-D__GHCJS__=" ++ versionInt version] ++ ["-D" ++ os ++ "_BUILD_OS=1"] ++ ["-D" ++ arch ++ "_BUILD_ARCH=1"] ++ map (\os' -> "-D" ++ os' ++ "_HOST_OS=1") osStr ++ map (\arch' -> "-D" ++ arch' ++ "_HOST_ARCH=1") archStr JHC -> ["-D__JHC__=" ++ versionInt version] HaskellSuite {} -> ["-D__HASKELL_SUITE__"] ++ map (\os' -> "-D" ++ os' ++ "_HOST_OS=1") osStr ++ map (\arch' -> "-D" ++ arch' ++ "_HOST_ARCH=1") archStr _ -> [] where comp = compiler lbi Platform hostArch hostOS = hostPlatform lbi version = compilerVersion comp compatGlasgowHaskell = maybe [] (\v -> ["-D__GLASGOW_HASKELL__=" ++ versionInt v]) (compilerCompatVersion GHC comp) -- TODO: move this into the compiler abstraction -- FIXME: this forces GHC's crazy 4.8.2 -> 408 convention on all -- the other compilers. Check if that's really what they want. versionInt :: Version -> String versionInt (Version { versionBranch = [] }) = "1" versionInt (Version { versionBranch = [n] }) = show n versionInt (Version { versionBranch = n1:n2:_ }) = -- 6.8.x -> 608 -- 6.10.x -> 610 let s1 = show n1 s2 = show n2 middle = case s2 of _ : _ : _ -> "" _ -> "0" in s1 ++ middle ++ s2 osStr = case hostOS of Linux -> ["linux"] Windows -> ["mingw32"] OSX -> ["darwin"] FreeBSD -> ["freebsd"] OpenBSD -> ["openbsd"] NetBSD -> ["netbsd"] DragonFly -> ["dragonfly"] Solaris -> ["solaris2"] AIX -> ["aix"] HPUX -> ["hpux"] IRIX -> ["irix"] HaLVM -> [] IOS -> ["ios"] Ghcjs -> ["ghcjs"] OtherOS _ -> [] archStr = case hostArch of I386 -> ["i386"] X86_64 -> ["x86_64"] PPC -> ["powerpc"] PPC64 -> ["powerpc64"] Sparc -> ["sparc"] Arm -> ["arm"] Mips -> ["mips"] SH -> [] IA64 -> ["ia64"] S390 -> ["s390"] Alpha -> ["alpha"] Hppa -> ["hppa"] Rs6000 -> ["rs6000"] M68k -> ["m68k"] Vax -> ["vax"] JavaScript -> ["javascript"] OtherArch _ -> [] ppHappy :: BuildInfo -> LocalBuildInfo -> PreProcessor ppHappy _ lbi = pp { platformIndependent = True } where pp = standardPP lbi happyProgram (hcFlags hc) hc = compilerFlavor (compiler lbi) hcFlags GHC = ["-agc"] hcFlags GHCJS = ["-agc"] hcFlags _ = [] ppAlex :: BuildInfo -> LocalBuildInfo -> PreProcessor ppAlex _ lbi = pp { platformIndependent = True } where pp = standardPP lbi alexProgram (hcFlags hc) hc = compilerFlavor (compiler lbi) hcFlags GHC = ["-g"] hcFlags GHCJS = ["-g"] hcFlags _ = [] standardPP :: LocalBuildInfo -> Program -> [String] -> PreProcessor standardPP lbi prog args = PreProcessor { platformIndependent = False, runPreProcessor = mkSimplePreProcessor $ \inFile outFile verbosity -> rawSystemProgramConf verbosity prog (withPrograms lbi) (args ++ ["-o", outFile, inFile]) } -- |Convenience function; get the suffixes of these preprocessors. ppSuffixes :: [ PPSuffixHandler ] -> [String] ppSuffixes = map fst -- |Standard preprocessors: GreenCard, c2hs, hsc2hs, happy, alex and cpphs. knownSuffixHandlers :: [ PPSuffixHandler ] knownSuffixHandlers = [ ("gc", ppGreenCard) , ("chs", ppC2hs) , ("hsc", ppHsc2hs) , ("x", ppAlex) , ("y", ppHappy) , ("ly", ppHappy) , ("cpphs", ppCpp) ] Cabal-1.22.5.0/Distribution/Simple/Program.hs0000644000000000000000000001622512627136220017011 0ustar0000000000000000----------------------------------------------------------------------------- -- | -- Module : Distribution.Simple.Program -- Copyright : Isaac Jones 2006, Duncan Coutts 2007-2009 -- -- Maintainer : cabal-devel@haskell.org -- Portability : portable -- -- This provides an abstraction which deals with configuring and running -- programs. A 'Program' is a static notion of a known program. A -- 'ConfiguredProgram' is a 'Program' that has been found on the current -- machine and is ready to be run (possibly with some user-supplied default -- args). Configuring a program involves finding its location and if necessary -- finding its version. There is also a 'ProgramConfiguration' type which holds -- configured and not-yet configured programs. It is the parameter to lots of -- actions elsewhere in Cabal that need to look up and run programs. If we had -- a Cabal monad, the 'ProgramConfiguration' would probably be a reader or -- state component of it. -- -- The module also defines all the known built-in 'Program's and the -- 'defaultProgramConfiguration' which contains them all. -- -- One nice thing about using it is that any program that is -- registered with Cabal will get some \"configure\" and \".cabal\" -- helpers like --with-foo-args --foo-path= and extra-foo-args. -- -- There's also good default behavior for trying to find \"foo\" in -- PATH, being able to override its location, etc. -- -- There's also a hook for adding programs in a Setup.lhs script. See -- hookedPrograms in 'Distribution.Simple.UserHooks'. This gives a -- hook user the ability to get the above flags and such so that they -- don't have to write all the PATH logic inside Setup.lhs. module Distribution.Simple.Program ( -- * Program and functions for constructing them Program(..) , ProgramSearchPath , ProgramSearchPathEntry(..) , simpleProgram , findProgramLocation , findProgramVersion -- * Configured program and related functions , ConfiguredProgram(..) , programPath , ProgArg , ProgramLocation(..) , runProgram , getProgramOutput , suppressOverrideArgs -- * Program invocations , ProgramInvocation(..) , emptyProgramInvocation , simpleProgramInvocation , programInvocation , runProgramInvocation , getProgramInvocationOutput -- * The collection of unconfigured and configured programs , builtinPrograms -- * The collection of configured programs we can run , ProgramConfiguration , emptyProgramConfiguration , defaultProgramConfiguration , restoreProgramConfiguration , addKnownProgram , addKnownPrograms , lookupKnownProgram , knownPrograms , getProgramSearchPath , setProgramSearchPath , userSpecifyPath , userSpecifyPaths , userMaybeSpecifyPath , userSpecifyArgs , userSpecifyArgss , userSpecifiedArgs , lookupProgram , lookupProgramVersion , updateProgram , configureProgram , configureAllKnownPrograms , reconfigurePrograms , requireProgram , requireProgramVersion , runDbProgram , getDbProgramOutput -- * Programs that Cabal knows about , ghcProgram , ghcPkgProgram , ghcjsProgram , ghcjsPkgProgram , lhcProgram , lhcPkgProgram , hmakeProgram , jhcProgram , uhcProgram , gccProgram , arProgram , stripProgram , happyProgram , alexProgram , hsc2hsProgram , c2hsProgram , cpphsProgram , hscolourProgram , haddockProgram , greencardProgram , ldProgram , tarProgram , cppProgram , pkgConfigProgram , hpcProgram -- * deprecated , rawSystemProgram , rawSystemProgramStdout , rawSystemProgramConf , rawSystemProgramStdoutConf , findProgramOnPath ) where import Distribution.Simple.Program.Types import Distribution.Simple.Program.Run import Distribution.Simple.Program.Db import Distribution.Simple.Program.Builtin import Distribution.Simple.Utils ( die, findProgramLocation, findProgramVersion ) import Distribution.Verbosity ( Verbosity ) -- | Runs the given configured program. -- runProgram :: Verbosity -- ^Verbosity -> ConfiguredProgram -- ^The program to run -> [ProgArg] -- ^Any /extra/ arguments to add -> IO () runProgram verbosity prog args = runProgramInvocation verbosity (programInvocation prog args) -- | Runs the given configured program and gets the output. -- getProgramOutput :: Verbosity -- ^Verbosity -> ConfiguredProgram -- ^The program to run -> [ProgArg] -- ^Any /extra/ arguments to add -> IO String getProgramOutput verbosity prog args = getProgramInvocationOutput verbosity (programInvocation prog args) -- | Looks up the given program in the program database and runs it. -- runDbProgram :: Verbosity -- ^verbosity -> Program -- ^The program to run -> ProgramDb -- ^look up the program here -> [ProgArg] -- ^Any /extra/ arguments to add -> IO () runDbProgram verbosity prog programDb args = case lookupProgram prog programDb of Nothing -> die notFound Just configuredProg -> runProgram verbosity configuredProg args where notFound = "The program '" ++ programName prog ++ "' is required but it could not be found" -- | Looks up the given program in the program database and runs it. -- getDbProgramOutput :: Verbosity -- ^verbosity -> Program -- ^The program to run -> ProgramDb -- ^look up the program here -> [ProgArg] -- ^Any /extra/ arguments to add -> IO String getDbProgramOutput verbosity prog programDb args = case lookupProgram prog programDb of Nothing -> die notFound Just configuredProg -> getProgramOutput verbosity configuredProg args where notFound = "The program '" ++ programName prog ++ "' is required but it could not be found" --------------------- -- Deprecated aliases -- rawSystemProgram :: Verbosity -> ConfiguredProgram -> [ProgArg] -> IO () rawSystemProgram = runProgram rawSystemProgramStdout :: Verbosity -> ConfiguredProgram -> [ProgArg] -> IO String rawSystemProgramStdout = getProgramOutput rawSystemProgramConf :: Verbosity -> Program -> ProgramConfiguration -> [ProgArg] -> IO () rawSystemProgramConf = runDbProgram rawSystemProgramStdoutConf :: Verbosity -> Program -> ProgramConfiguration -> [ProgArg] -> IO String rawSystemProgramStdoutConf = getDbProgramOutput type ProgramConfiguration = ProgramDb emptyProgramConfiguration, defaultProgramConfiguration :: ProgramConfiguration emptyProgramConfiguration = emptyProgramDb defaultProgramConfiguration = defaultProgramDb restoreProgramConfiguration :: [Program] -> ProgramConfiguration -> ProgramConfiguration restoreProgramConfiguration = restoreProgramDb {-# DEPRECATED findProgramOnPath "use findProgramLocation instead" #-} findProgramOnPath :: String -> Verbosity -> IO (Maybe FilePath) findProgramOnPath = flip findProgramLocation Cabal-1.22.5.0/Distribution/Simple/Register.hs0000644000000000000000000004770212627136220017172 0ustar0000000000000000----------------------------------------------------------------------------- -- | -- Module : Distribution.Simple.Register -- Copyright : Isaac Jones 2003-2004 -- License : BSD3 -- -- Maintainer : cabal-devel@haskell.org -- Portability : portable -- -- This module deals with registering and unregistering packages. There are a -- couple ways it can do this, one is to do it directly. Another is to generate -- a script that can be run later to do it. The idea here being that the user -- is shielded from the details of what command to use for package registration -- for a particular compiler. In practice this aspect was not especially -- popular so we also provide a way to simply generate the package registration -- file which then must be manually passed to @ghc-pkg@. It is possible to -- generate registration information for where the package is to be installed, -- or alternatively to register the package in place in the build tree. The -- latter is occasionally handy, and will become more important when we try to -- build multi-package systems. -- -- This module does not delegate anything to the per-compiler modules but just -- mixes it all in in this module, which is rather unsatisfactory. The script -- generation and the unregister feature are not well used or tested. module Distribution.Simple.Register ( register, unregister, initPackageDB, invokeHcPkg, registerPackage, generateRegistrationInfo, inplaceInstalledPackageInfo, absoluteInstalledPackageInfo, generalInstalledPackageInfo, ) where import Distribution.Simple.LocalBuildInfo ( LocalBuildInfo(..), ComponentLocalBuildInfo(..) , ComponentName(..), getComponentLocalBuildInfo , LibraryName(..) , InstallDirs(..), absoluteInstallDirs ) import Distribution.Simple.BuildPaths (haddockName) import qualified Distribution.Simple.GHC as GHC import qualified Distribution.Simple.GHCJS as GHCJS import qualified Distribution.Simple.LHC as LHC import qualified Distribution.Simple.UHC as UHC import qualified Distribution.Simple.HaskellSuite as HaskellSuite import Distribution.Simple.Compiler ( compilerVersion, Compiler, CompilerFlavor(..), compilerFlavor , PackageDB, PackageDBStack, absolutePackageDBPaths , registrationPackageDB ) import Distribution.Simple.Program ( ProgramConfiguration, runProgramInvocation ) import Distribution.Simple.Program.Script ( invocationAsSystemScript ) import Distribution.Simple.Program.HcPkg (HcPkgInfo) import qualified Distribution.Simple.Program.HcPkg as HcPkg import Distribution.Simple.Setup ( RegisterFlags(..), CopyDest(..) , fromFlag, fromFlagOrDefault, flagToMaybe ) import Distribution.PackageDescription ( PackageDescription(..), Library(..), BuildInfo(..), libModules ) import Distribution.Package ( Package(..), packageName, InstalledPackageId(..) ) import Distribution.InstalledPackageInfo ( InstalledPackageInfo, InstalledPackageInfo_(InstalledPackageInfo) , showInstalledPackageInfo ) import qualified Distribution.InstalledPackageInfo as IPI import Distribution.Simple.Utils ( writeUTF8File, writeFileAtomic, setFileExecutable , die, notice, setupMessage, shortRelativePath ) import Distribution.System ( OS(..), buildOS ) import Distribution.Text ( display ) import Distribution.Version ( Version(..) ) import Distribution.Verbosity as Verbosity ( Verbosity, normal ) import System.FilePath ((), (<.>), isAbsolute) import System.Directory ( getCurrentDirectory ) import Control.Monad (when) import Data.Maybe ( isJust, fromMaybe, maybeToList ) import Data.List ( partition, nub ) import qualified Data.ByteString.Lazy.Char8 as BS.Char8 -- ----------------------------------------------------------------------------- -- Registration register :: PackageDescription -> LocalBuildInfo -> RegisterFlags -- ^Install in the user's database?; verbose -> IO () register pkg@PackageDescription { library = Just lib } lbi regFlags = do let clbi = getComponentLocalBuildInfo lbi CLibName absPackageDBs <- absolutePackageDBPaths packageDbs installedPkgInfo <- generateRegistrationInfo verbosity pkg lib lbi clbi inplace reloc distPref (registrationPackageDB absPackageDBs) when (fromFlag (regPrintId regFlags)) $ do putStrLn (display (IPI.installedPackageId installedPkgInfo)) -- Three different modes: case () of _ | modeGenerateRegFile -> writeRegistrationFile installedPkgInfo | modeGenerateRegScript -> writeRegisterScript installedPkgInfo | otherwise -> registerPackage verbosity installedPkgInfo pkg lbi inplace packageDbs where modeGenerateRegFile = isJust (flagToMaybe (regGenPkgConf regFlags)) regFile = fromMaybe (display (packageId pkg) <.> "conf") (fromFlag (regGenPkgConf regFlags)) modeGenerateRegScript = fromFlag (regGenScript regFlags) inplace = fromFlag (regInPlace regFlags) reloc = relocatable lbi -- FIXME: there's really no guarantee this will work. -- registering into a totally different db stack can -- fail if dependencies cannot be satisfied. packageDbs = nub $ withPackageDB lbi ++ maybeToList (flagToMaybe (regPackageDB regFlags)) distPref = fromFlag (regDistPref regFlags) verbosity = fromFlag (regVerbosity regFlags) writeRegistrationFile installedPkgInfo = do notice verbosity ("Creating package registration file: " ++ regFile) writeUTF8File regFile (showInstalledPackageInfo installedPkgInfo) writeRegisterScript installedPkgInfo = case compilerFlavor (compiler lbi) of JHC -> notice verbosity "Registration scripts not needed for jhc" UHC -> notice verbosity "Registration scripts not needed for uhc" _ -> withHcPkg "Registration scripts are not implemented for this compiler" (compiler lbi) (withPrograms lbi) (writeHcPkgRegisterScript verbosity installedPkgInfo packageDbs) register _ _ regFlags = notice verbosity "No package to register" where verbosity = fromFlag (regVerbosity regFlags) generateRegistrationInfo :: Verbosity -> PackageDescription -> Library -> LocalBuildInfo -> ComponentLocalBuildInfo -> Bool -> Bool -> FilePath -> PackageDB -> IO InstalledPackageInfo generateRegistrationInfo verbosity pkg lib lbi clbi inplace reloc distPref packageDb = do --TODO: eliminate pwd! pwd <- getCurrentDirectory --TODO: the method of setting the InstalledPackageId is compiler specific -- this aspect should be delegated to a per-compiler helper. let comp = compiler lbi ipid <- case compilerFlavor comp of GHC | compilerVersion comp >= Version [6,11] [] -> do s <- GHC.libAbiHash verbosity pkg lbi lib clbi return (InstalledPackageId (display (packageId pkg) ++ '-':s)) GHCJS -> do s <- GHCJS.libAbiHash verbosity pkg lbi lib clbi return (InstalledPackageId (display (packageId pkg) ++ '-':s)) _other -> do return (InstalledPackageId (display (packageId pkg))) installedPkgInfo <- if inplace then return (inplaceInstalledPackageInfo pwd distPref pkg ipid lib lbi clbi) else if reloc then relocRegistrationInfo verbosity pkg lib lbi clbi ipid packageDb else return (absoluteInstalledPackageInfo pkg ipid lib lbi clbi) return installedPkgInfo{ IPI.installedPackageId = ipid } relocRegistrationInfo :: Verbosity -> PackageDescription -> Library -> LocalBuildInfo -> ComponentLocalBuildInfo -> InstalledPackageId -> PackageDB -> IO InstalledPackageInfo relocRegistrationInfo verbosity pkg lib lbi clbi ipid packageDb = case (compilerFlavor (compiler lbi)) of GHC -> do fs <- GHC.pkgRoot verbosity lbi packageDb return (relocatableInstalledPackageInfo pkg ipid lib lbi clbi fs) _ -> die "Distribution.Simple.Register.relocRegistrationInfo: \ \not implemented for this compiler" -- | Create an empty package DB at the specified location. initPackageDB :: Verbosity -> Compiler -> ProgramConfiguration -> FilePath -> IO () initPackageDB verbosity comp conf dbPath = case compilerFlavor comp of HaskellSuite {} -> HaskellSuite.initPackageDB verbosity conf dbPath _ -> withHcPkg "Distribution.Simple.Register.initPackageDB: \ \not implemented for this compiler" comp conf (\hpi -> HcPkg.init hpi verbosity dbPath) -- | Run @hc-pkg@ using a given package DB stack, directly forwarding the -- provided command-line arguments to it. invokeHcPkg :: Verbosity -> Compiler -> ProgramConfiguration -> PackageDBStack -> [String] -> IO () invokeHcPkg verbosity comp conf dbStack extraArgs = withHcPkg "invokeHcPkg" comp conf (\hpi -> HcPkg.invoke hpi verbosity dbStack extraArgs) withHcPkg :: String -> Compiler -> ProgramConfiguration -> (HcPkgInfo -> IO a) -> IO a withHcPkg name comp conf f = case compilerFlavor comp of GHC -> f (GHC.hcPkgInfo conf) GHCJS -> f (GHCJS.hcPkgInfo conf) LHC -> f (LHC.hcPkgInfo conf) _ -> die ("Distribution.Simple.Register." ++ name ++ ":\ \not implemented for this compiler") registerPackage :: Verbosity -> InstalledPackageInfo -> PackageDescription -> LocalBuildInfo -> Bool -> PackageDBStack -> IO () registerPackage verbosity installedPkgInfo pkg lbi inplace packageDbs = do let msg = if inplace then "In-place registering" else "Registering" setupMessage verbosity msg (packageId pkg) case compilerFlavor (compiler lbi) of GHC -> GHC.registerPackage verbosity installedPkgInfo pkg lbi inplace packageDbs GHCJS -> GHCJS.registerPackage verbosity installedPkgInfo pkg lbi inplace packageDbs LHC -> LHC.registerPackage verbosity installedPkgInfo pkg lbi inplace packageDbs UHC -> UHC.registerPackage verbosity installedPkgInfo pkg lbi inplace packageDbs JHC -> notice verbosity "Registering for jhc (nothing to do)" HaskellSuite {} -> HaskellSuite.registerPackage verbosity installedPkgInfo pkg lbi inplace packageDbs _ -> die "Registering is not implemented for this compiler" writeHcPkgRegisterScript :: Verbosity -> InstalledPackageInfo -> PackageDBStack -> HcPkgInfo -> IO () writeHcPkgRegisterScript verbosity installedPkgInfo packageDbs hpi = do let invocation = HcPkg.reregisterInvocation hpi Verbosity.normal packageDbs (Right installedPkgInfo) regScript = invocationAsSystemScript buildOS invocation notice verbosity ("Creating package registration script: " ++ regScriptFileName) writeUTF8File regScriptFileName regScript setFileExecutable regScriptFileName regScriptFileName :: FilePath regScriptFileName = case buildOS of Windows -> "register.bat" _ -> "register.sh" -- ----------------------------------------------------------------------------- -- Making the InstalledPackageInfo -- | Construct 'InstalledPackageInfo' for a library in a package, given a set -- of installation directories. -- generalInstalledPackageInfo :: ([FilePath] -> [FilePath]) -- ^ Translate relative include dir paths to -- absolute paths. -> PackageDescription -> InstalledPackageId -> Library -> LocalBuildInfo -> ComponentLocalBuildInfo -> InstallDirs FilePath -> InstalledPackageInfo generalInstalledPackageInfo adjustRelIncDirs pkg ipid lib lbi clbi installDirs = InstalledPackageInfo { IPI.installedPackageId = ipid, IPI.sourcePackageId = packageId pkg, IPI.packageKey = pkgKey lbi, IPI.license = license pkg, IPI.copyright = copyright pkg, IPI.maintainer = maintainer pkg, IPI.author = author pkg, IPI.stability = stability pkg, IPI.homepage = homepage pkg, IPI.pkgUrl = pkgUrl pkg, IPI.synopsis = synopsis pkg, IPI.description = description pkg, IPI.category = category pkg, IPI.exposed = libExposed lib, IPI.exposedModules = map fixupSelf (componentExposedModules clbi), IPI.hiddenModules = otherModules bi, IPI.instantiatedWith = map (\(k,(p,n)) -> (k,IPI.OriginalModule (IPI.installedPackageId p) n)) (instantiatedWith lbi), IPI.trusted = IPI.trusted IPI.emptyInstalledPackageInfo, IPI.importDirs = [ libdir installDirs | hasModules ], -- Note. the libsubdir and datasubdir templates have already been expanded -- into libdir and datadir. IPI.libraryDirs = if hasLibrary then libdir installDirs : extraLibDirs bi else extraLibDirs bi, IPI.dataDir = datadir installDirs, IPI.hsLibraries = [ libname | LibraryName libname <- componentLibraries clbi , hasLibrary ], IPI.extraLibraries = extraLibs bi, IPI.extraGHCiLibraries = extraGHCiLibs bi, IPI.includeDirs = absinc ++ adjustRelIncDirs relinc, IPI.includes = includes bi, IPI.depends = map fst (componentPackageDeps clbi), IPI.ccOptions = [], -- Note. NOT ccOptions bi! -- We don't want cc-options to be propagated -- to C compilations in other packages. IPI.ldOptions = ldOptions bi, IPI.frameworkDirs = [], IPI.frameworks = frameworks bi, IPI.haddockInterfaces = [haddockdir installDirs haddockName pkg], IPI.haddockHTMLs = [htmldir installDirs], IPI.pkgRoot = Nothing } where bi = libBuildInfo lib (absinc, relinc) = partition isAbsolute (includeDirs bi) hasModules = not $ null (libModules lib) hasLibrary = hasModules || not (null (cSources bi)) || (not (null (jsSources bi)) && compilerFlavor (compiler lbi) == GHCJS) -- Since we currently don't decide the InstalledPackageId of our package -- until just before we register, we didn't have one for the re-exports -- of modules defined within this package, so we used an empty one that -- we fill in here now that we know what it is. It's a bit of a hack, -- we ought really to decide the InstalledPackageId ahead of time. fixupSelf (IPI.ExposedModule n o o') = IPI.ExposedModule n (fmap fixupOriginalModule o) (fmap fixupOriginalModule o') fixupOriginalModule (IPI.OriginalModule i m) = IPI.OriginalModule (fixupIpid i) m fixupIpid (InstalledPackageId []) = ipid fixupIpid x = x -- | Construct 'InstalledPackageInfo' for a library that is in place in the -- build tree. -- -- This function knows about the layout of in place packages. -- inplaceInstalledPackageInfo :: FilePath -- ^ top of the build tree -> FilePath -- ^ location of the dist tree -> PackageDescription -> InstalledPackageId -> Library -> LocalBuildInfo -> ComponentLocalBuildInfo -> InstalledPackageInfo inplaceInstalledPackageInfo inplaceDir distPref pkg ipid lib lbi clbi = generalInstalledPackageInfo adjustRelativeIncludeDirs pkg ipid lib lbi clbi installDirs where adjustRelativeIncludeDirs = map (inplaceDir ) installDirs = (absoluteInstallDirs pkg lbi NoCopyDest) { libdir = inplaceDir buildDir lbi, datadir = inplaceDir dataDir pkg, docdir = inplaceDocdir, htmldir = inplaceHtmldir, haddockdir = inplaceHtmldir } inplaceDocdir = inplaceDir distPref "doc" inplaceHtmldir = inplaceDocdir "html" display (packageName pkg) -- | Construct 'InstalledPackageInfo' for the final install location of a -- library package. -- -- This function knows about the layout of installed packages. -- absoluteInstalledPackageInfo :: PackageDescription -> InstalledPackageId -> Library -> LocalBuildInfo -> ComponentLocalBuildInfo -> InstalledPackageInfo absoluteInstalledPackageInfo pkg ipid lib lbi clbi = generalInstalledPackageInfo adjustReativeIncludeDirs pkg ipid lib lbi clbi installDirs where -- For installed packages we install all include files into one dir, -- whereas in the build tree they may live in multiple local dirs. adjustReativeIncludeDirs _ | null (installIncludes bi) = [] | otherwise = [includedir installDirs] bi = libBuildInfo lib installDirs = absoluteInstallDirs pkg lbi NoCopyDest relocatableInstalledPackageInfo :: PackageDescription -> InstalledPackageId -> Library -> LocalBuildInfo -> ComponentLocalBuildInfo -> FilePath -> InstalledPackageInfo relocatableInstalledPackageInfo pkg ipid lib lbi clbi pkgroot = generalInstalledPackageInfo adjustReativeIncludeDirs pkg ipid lib lbi clbi installDirs where -- For installed packages we install all include files into one dir, -- whereas in the build tree they may live in multiple local dirs. adjustReativeIncludeDirs _ | null (installIncludes bi) = [] | otherwise = [includedir installDirs] bi = libBuildInfo lib installDirs = fmap (("${pkgroot}" ) . shortRelativePath pkgroot) $ absoluteInstallDirs pkg lbi NoCopyDest -- ----------------------------------------------------------------------------- -- Unregistration unregister :: PackageDescription -> LocalBuildInfo -> RegisterFlags -> IO () unregister pkg lbi regFlags = do let pkgid = packageId pkg genScript = fromFlag (regGenScript regFlags) verbosity = fromFlag (regVerbosity regFlags) packageDb = fromFlagOrDefault (registrationPackageDB (withPackageDB lbi)) (regPackageDB regFlags) unreg hpi = let invocation = HcPkg.unregisterInvocation hpi Verbosity.normal packageDb pkgid in if genScript then writeFileAtomic unregScriptFileName (BS.Char8.pack $ invocationAsSystemScript buildOS invocation) else runProgramInvocation verbosity invocation setupMessage verbosity "Unregistering" pkgid withHcPkg "unregistering is only implemented for GHC and GHCJS" (compiler lbi) (withPrograms lbi) unreg unregScriptFileName :: FilePath unregScriptFileName = case buildOS of Windows -> "unregister.bat" _ -> "unregister.sh" Cabal-1.22.5.0/Distribution/Simple/Setup.hs0000644000000000000000000025104512627136220016503 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveGeneric #-} ----------------------------------------------------------------------------- -- | -- Module : Distribution.Simple.Setup -- Copyright : Isaac Jones 2003-2004 -- Duncan Coutts 2007 -- License : BSD3 -- -- Maintainer : cabal-devel@haskell.org -- Portability : portable -- -- This is a big module, but not very complicated. The code is very regular -- and repetitive. It defines the command line interface for all the Cabal -- commands. For each command (like @configure@, @build@ etc) it defines a type -- that holds all the flags, the default set of flags and a 'CommandUI' that -- maps command line flags to and from the corresponding flags type. -- -- All the flags types are instances of 'Monoid', see -- -- for an explanation. -- -- The types defined here get used in the front end and especially in -- @cabal-install@ which has to do quite a bit of manipulating sets of command -- line flags. -- -- This is actually relatively nice, it works quite well. The main change it -- needs is to unify it with the code for managing sets of fields that can be -- read and written from files. This would allow us to save configure flags in -- config files. {-# LANGUAGE CPP #-} module Distribution.Simple.Setup ( GlobalFlags(..), emptyGlobalFlags, defaultGlobalFlags, globalCommand, ConfigFlags(..), emptyConfigFlags, defaultConfigFlags, configureCommand, configAbsolutePaths, readPackageDbList, showPackageDbList, CopyFlags(..), emptyCopyFlags, defaultCopyFlags, copyCommand, InstallFlags(..), emptyInstallFlags, defaultInstallFlags, installCommand, HaddockFlags(..), emptyHaddockFlags, defaultHaddockFlags, haddockCommand, HscolourFlags(..), emptyHscolourFlags, defaultHscolourFlags, hscolourCommand, BuildFlags(..), emptyBuildFlags, defaultBuildFlags, buildCommand, buildVerbose, ReplFlags(..), defaultReplFlags, replCommand, CleanFlags(..), emptyCleanFlags, defaultCleanFlags, cleanCommand, RegisterFlags(..), emptyRegisterFlags, defaultRegisterFlags, registerCommand, unregisterCommand, SDistFlags(..), emptySDistFlags, defaultSDistFlags, sdistCommand, TestFlags(..), emptyTestFlags, defaultTestFlags, testCommand, TestShowDetails(..), BenchmarkFlags(..), emptyBenchmarkFlags, defaultBenchmarkFlags, benchmarkCommand, CopyDest(..), configureArgs, configureOptions, configureCCompiler, configureLinker, buildOptions, haddockOptions, installDirsOptions, programConfigurationOptions, programConfigurationPaths', defaultDistPref, Flag(..), toFlag, fromFlag, fromFlagOrDefault, flagToMaybe, flagToList, boolOpt, boolOpt', trueArg, falseArg, optionVerbosity, optionNumJobs ) where import Distribution.Compiler () import Distribution.ReadE import Distribution.Text ( Text(..), display ) import qualified Distribution.Compat.ReadP as Parse import qualified Text.PrettyPrint as Disp import Distribution.ModuleName import Distribution.Package ( Dependency(..) , PackageName , InstalledPackageId ) import Distribution.PackageDescription ( FlagName(..), FlagAssignment ) import Distribution.Simple.Command hiding (boolOpt, boolOpt') import qualified Distribution.Simple.Command as Command import Distribution.Simple.Compiler ( CompilerFlavor(..), defaultCompilerFlavor, PackageDB(..) , DebugInfoLevel(..), flagToDebugInfoLevel , OptimisationLevel(..), flagToOptimisationLevel , absolutePackageDBPath ) import Distribution.Simple.Utils ( wrapText, wrapLine, lowercase, intercalate ) import Distribution.Simple.Program (Program(..), ProgramConfiguration, requireProgram, programInvocation, progInvokePath, progInvokeArgs, knownPrograms, addKnownProgram, emptyProgramConfiguration, haddockProgram, ghcProgram, gccProgram, ldProgram) import Distribution.Simple.InstallDirs ( InstallDirs(..), CopyDest(..), PathTemplate, toPathTemplate, fromPathTemplate ) import Distribution.Verbosity import Distribution.Utils.NubList import Control.Monad (liftM) import Distribution.Compat.Binary (Binary) import Data.List ( sort ) import Data.Char ( isSpace, isAlpha ) #if __GLASGOW_HASKELL__ < 710 import Data.Monoid ( Monoid(..) ) #endif import GHC.Generics (Generic) -- FIXME Not sure where this should live defaultDistPref :: FilePath defaultDistPref = "dist" -- ------------------------------------------------------------ -- * Flag type -- ------------------------------------------------------------ -- | All flags are monoids, they come in two flavours: -- -- 1. list flags eg -- -- > --ghc-option=foo --ghc-option=bar -- -- gives us all the values ["foo", "bar"] -- -- 2. singular value flags, eg: -- -- > --enable-foo --disable-foo -- -- gives us Just False -- So this Flag type is for the latter singular kind of flag. -- Its monoid instance gives us the behaviour where it starts out as -- 'NoFlag' and later flags override earlier ones. -- data Flag a = Flag a | NoFlag deriving (Eq, Generic, Show, Read) instance Binary a => Binary (Flag a) instance Functor Flag where fmap f (Flag x) = Flag (f x) fmap _ NoFlag = NoFlag instance Monoid (Flag a) where mempty = NoFlag _ `mappend` f@(Flag _) = f f `mappend` NoFlag = f instance Bounded a => Bounded (Flag a) where minBound = toFlag minBound maxBound = toFlag maxBound instance Enum a => Enum (Flag a) where fromEnum = fromEnum . fromFlag toEnum = toFlag . toEnum enumFrom (Flag a) = map toFlag . enumFrom $ a enumFrom _ = [] enumFromThen (Flag a) (Flag b) = toFlag `map` enumFromThen a b enumFromThen _ _ = [] enumFromTo (Flag a) (Flag b) = toFlag `map` enumFromTo a b enumFromTo _ _ = [] enumFromThenTo (Flag a) (Flag b) (Flag c) = toFlag `map` enumFromThenTo a b c enumFromThenTo _ _ _ = [] toFlag :: a -> Flag a toFlag = Flag fromFlag :: Flag a -> a fromFlag (Flag x) = x fromFlag NoFlag = error "fromFlag NoFlag. Use fromFlagOrDefault" fromFlagOrDefault :: a -> Flag a -> a fromFlagOrDefault _ (Flag x) = x fromFlagOrDefault def NoFlag = def flagToMaybe :: Flag a -> Maybe a flagToMaybe (Flag x) = Just x flagToMaybe NoFlag = Nothing flagToList :: Flag a -> [a] flagToList (Flag x) = [x] flagToList NoFlag = [] allFlags :: [Flag Bool] -> Flag Bool allFlags flags = if all (\f -> fromFlagOrDefault False f) flags then Flag True else NoFlag -- ------------------------------------------------------------ -- * Global flags -- ------------------------------------------------------------ -- In fact since individual flags types are monoids and these are just sets of -- flags then they are also monoids pointwise. This turns out to be really -- useful. The mempty is the set of empty flags and mappend allows us to -- override specific flags. For example we can start with default flags and -- override with the ones we get from a file or the command line, or both. -- | Flags that apply at the top level, not to any sub-command. data GlobalFlags = GlobalFlags { globalVersion :: Flag Bool, globalNumericVersion :: Flag Bool } defaultGlobalFlags :: GlobalFlags defaultGlobalFlags = GlobalFlags { globalVersion = Flag False, globalNumericVersion = Flag False } globalCommand :: [Command action] -> CommandUI GlobalFlags globalCommand commands = CommandUI { commandName = "" , commandSynopsis = "" , commandUsage = \pname -> "This Setup program uses the Haskell Cabal Infrastructure.\n" ++ "See http://www.haskell.org/cabal/ for more information.\n" ++ "\n" ++ "Usage: " ++ pname ++ " [GLOBAL FLAGS] [COMMAND [FLAGS]]\n" , commandDescription = Just $ \pname -> let commands' = commands ++ [commandAddAction helpCommandUI undefined] cmdDescs = getNormalCommandDescriptions commands' maxlen = maximum $ [length name | (name, _) <- cmdDescs] align str = str ++ replicate (maxlen - length str) ' ' in "Commands:\n" ++ unlines [ " " ++ align name ++ " " ++ description | (name, description) <- cmdDescs ] ++ "\n" ++ "For more information about a command use\n" ++ " " ++ pname ++ " COMMAND --help\n\n" ++ "Typical steps for installing Cabal packages:\n" ++ concat [ " " ++ pname ++ " " ++ x ++ "\n" | x <- ["configure", "build", "install"]] , commandNotes = Nothing , commandDefaultFlags = defaultGlobalFlags , commandOptions = \_ -> [option ['V'] ["version"] "Print version information" globalVersion (\v flags -> flags { globalVersion = v }) trueArg ,option [] ["numeric-version"] "Print just the version number" globalNumericVersion (\v flags -> flags { globalNumericVersion = v }) trueArg ] } emptyGlobalFlags :: GlobalFlags emptyGlobalFlags = mempty instance Monoid GlobalFlags where mempty = GlobalFlags { globalVersion = mempty, globalNumericVersion = mempty } mappend a b = GlobalFlags { globalVersion = combine globalVersion, globalNumericVersion = combine globalNumericVersion } where combine field = field a `mappend` field b -- ------------------------------------------------------------ -- * Config flags -- ------------------------------------------------------------ -- | Flags to @configure@ command. -- -- IMPORTANT: every time a new flag is added, 'D.C.Setup.filterConfigureFlags' -- should be updated. data ConfigFlags = ConfigFlags { --FIXME: the configPrograms is only here to pass info through to configure -- because the type of configure is constrained by the UserHooks. -- when we change UserHooks next we should pass the initial -- ProgramConfiguration directly and not via ConfigFlags configPrograms :: ProgramConfiguration, -- ^All programs that cabal may -- run configProgramPaths :: [(String, FilePath)], -- ^user specified programs paths configProgramArgs :: [(String, [String])], -- ^user specified programs args configProgramPathExtra :: NubList FilePath, -- ^Extend the $PATH configHcFlavor :: Flag CompilerFlavor, -- ^The \"flavor\" of the -- compiler, such as GHC or -- JHC. configHcPath :: Flag FilePath, -- ^given compiler location configHcPkg :: Flag FilePath, -- ^given hc-pkg location configVanillaLib :: Flag Bool, -- ^Enable vanilla library configProfLib :: Flag Bool, -- ^Enable profiling in the library configSharedLib :: Flag Bool, -- ^Build shared library configDynExe :: Flag Bool, -- ^Enable dynamic linking of the -- executables. configProfExe :: Flag Bool, -- ^Enable profiling in the -- executables. configConfigureArgs :: [String], -- ^Extra arguments to @configure@ configOptimization :: Flag OptimisationLevel, -- ^Enable optimization. configProgPrefix :: Flag PathTemplate, -- ^Installed executable prefix. configProgSuffix :: Flag PathTemplate, -- ^Installed executable suffix. configInstallDirs :: InstallDirs (Flag PathTemplate), -- ^Installation -- paths configScratchDir :: Flag FilePath, configExtraLibDirs :: [FilePath], -- ^ path to search for extra libraries configExtraIncludeDirs :: [FilePath], -- ^ path to search for header files configDistPref :: Flag FilePath, -- ^"dist" prefix configVerbosity :: Flag Verbosity, -- ^verbosity level configUserInstall :: Flag Bool, -- ^The --user\/--global flag configPackageDBs :: [Maybe PackageDB], -- ^Which package DBs to use configGHCiLib :: Flag Bool, -- ^Enable compiling library for GHCi configSplitObjs :: Flag Bool, -- ^Enable -split-objs with GHC configStripExes :: Flag Bool, -- ^Enable executable stripping configStripLibs :: Flag Bool, -- ^Enable library stripping configConstraints :: [Dependency], -- ^Additional constraints for -- dependencies. configDependencies :: [(PackageName, InstalledPackageId)], configInstantiateWith :: [(ModuleName, (InstalledPackageId, ModuleName))], -- ^The packages depended on. configConfigurationsFlags :: FlagAssignment, configTests :: Flag Bool, -- ^Enable test suite compilation configBenchmarks :: Flag Bool, -- ^Enable benchmark compilation configCoverage :: Flag Bool, -- ^Enable program coverage configLibCoverage :: Flag Bool, -- ^Enable program coverage (deprecated) configExactConfiguration :: Flag Bool, -- ^All direct dependencies and flags are provided on the command line by -- the user via the '--dependency' and '--flags' options. configFlagError :: Flag String, -- ^Halt and show an error message indicating an error in flag assignment configRelocatable :: Flag Bool, -- ^ Enable relocatable package built configDebugInfo :: Flag DebugInfoLevel -- ^ Emit debug info. } deriving (Generic, Read, Show) instance Binary ConfigFlags configAbsolutePaths :: ConfigFlags -> IO ConfigFlags configAbsolutePaths f = (\v -> f { configPackageDBs = v }) `liftM` mapM (maybe (return Nothing) (liftM Just . absolutePackageDBPath)) (configPackageDBs f) defaultConfigFlags :: ProgramConfiguration -> ConfigFlags defaultConfigFlags progConf = emptyConfigFlags { configPrograms = progConf, configHcFlavor = maybe NoFlag Flag defaultCompilerFlavor, configVanillaLib = Flag True, configProfLib = NoFlag, configSharedLib = NoFlag, configDynExe = Flag False, configProfExe = NoFlag, configOptimization = Flag NormalOptimisation, configProgPrefix = Flag (toPathTemplate ""), configProgSuffix = Flag (toPathTemplate ""), configDistPref = Flag defaultDistPref, configVerbosity = Flag normal, configUserInstall = Flag False, --TODO: reverse this #if defined(mingw32_HOST_OS) -- See #1589. configGHCiLib = Flag True, #else configGHCiLib = NoFlag, #endif configSplitObjs = Flag False, -- takes longer, so turn off by default configStripExes = Flag True, configStripLibs = Flag True, configTests = Flag False, configBenchmarks = Flag False, configCoverage = Flag False, configLibCoverage = NoFlag, configExactConfiguration = Flag False, configFlagError = NoFlag, configRelocatable = Flag False, configDebugInfo = Flag NoDebugInfo } configureCommand :: ProgramConfiguration -> CommandUI ConfigFlags configureCommand progConf = CommandUI { commandName = "configure" , commandSynopsis = "Prepare to build the package." , commandDescription = Just $ \_ -> wrapText $ "Configure how the package is built by setting " ++ "package (and other) flags.\n" ++ "\n" ++ "The configuration affects several other commands, " ++ "including build, test, bench, run, repl.\n" , commandNotes = Just (\_ -> programFlagsDescription progConf) , commandUsage = \pname -> "Usage: " ++ pname ++ " configure [FLAGS]\n" , commandDefaultFlags = defaultConfigFlags progConf , commandOptions = \showOrParseArgs -> configureOptions showOrParseArgs ++ programConfigurationPaths progConf showOrParseArgs configProgramPaths (\v fs -> fs { configProgramPaths = v }) ++ programConfigurationOption progConf showOrParseArgs configProgramArgs (\v fs -> fs { configProgramArgs = v }) ++ programConfigurationOptions progConf showOrParseArgs configProgramArgs (\v fs -> fs { configProgramArgs = v }) } configureOptions :: ShowOrParseArgs -> [OptionField ConfigFlags] configureOptions showOrParseArgs = [optionVerbosity configVerbosity (\v flags -> flags { configVerbosity = v }) ,optionDistPref configDistPref (\d flags -> flags { configDistPref = d }) showOrParseArgs ,option [] ["compiler"] "compiler" configHcFlavor (\v flags -> flags { configHcFlavor = v }) (choiceOpt [ (Flag GHC, ("g", ["ghc"]), "compile with GHC") , (Flag GHCJS, ([] , ["ghcjs"]), "compile with GHCJS") , (Flag JHC, ([] , ["jhc"]), "compile with JHC") , (Flag LHC, ([] , ["lhc"]), "compile with LHC") , (Flag UHC, ([] , ["uhc"]), "compile with UHC") -- "haskell-suite" compiler id string will be replaced -- by a more specific one during the configure stage , (Flag (HaskellSuite "haskell-suite"), ([] , ["haskell-suite"]), "compile with a haskell-suite compiler")]) ,option "w" ["with-compiler"] "give the path to a particular compiler" configHcPath (\v flags -> flags { configHcPath = v }) (reqArgFlag "PATH") ,option "" ["with-hc-pkg"] "give the path to the package tool" configHcPkg (\v flags -> flags { configHcPkg = v }) (reqArgFlag "PATH") ] ++ map liftInstallDirs installDirsOptions ++ [option "" ["program-prefix"] "prefix to be applied to installed executables" configProgPrefix (\v flags -> flags { configProgPrefix = v }) (reqPathTemplateArgFlag "PREFIX") ,option "" ["program-suffix"] "suffix to be applied to installed executables" configProgSuffix (\v flags -> flags { configProgSuffix = v } ) (reqPathTemplateArgFlag "SUFFIX") ,option "" ["library-vanilla"] "Vanilla libraries" configVanillaLib (\v flags -> flags { configVanillaLib = v }) (boolOpt [] []) ,option "p" ["library-profiling"] "Library profiling" configProfLib (\v flags -> flags { configProfLib = v }) (boolOpt "p" []) ,option "" ["shared"] "Shared library" configSharedLib (\v flags -> flags { configSharedLib = v }) (boolOpt [] []) ,option "" ["executable-dynamic"] "Executable dynamic linking" configDynExe (\v flags -> flags { configDynExe = v }) (boolOpt [] []) ,option "" ["profiling"] "Executable profiling (requires library profiling)" -- HACK: See #2409. Thankfully, this is 1.22-specific. (\flags -> case (configProfLib flags, configProfExe flags) of (Flag a, Flag b) | (a == b) && ("cabalConfProf", "/TRUE") `elem` configProgramPaths flags -> configProfExe flags _ -> NoFlag) (\v flags -> flags { configProfLib = v, configProfExe = v , configProgramPaths = ("cabalConfProf", "/TRUE") : configProgramPaths flags }) (boolOpt [] []) ,option "" ["executable-profiling"] "Executable profiling (DEPRECATED)" configProfExe (\v flags -> flags { configProfExe = v }) (boolOpt [] []) ,multiOption "optimization" configOptimization (\v flags -> flags { configOptimization = v }) [optArg' "n" (Flag . flagToOptimisationLevel) (\f -> case f of Flag NoOptimisation -> [] Flag NormalOptimisation -> [Nothing] Flag MaximumOptimisation -> [Just "2"] _ -> []) "O" ["enable-optimization","enable-optimisation"] "Build with optimization (n is 0--2, default is 1)", noArg (Flag NoOptimisation) [] ["disable-optimization","disable-optimisation"] "Build without optimization" ] ,multiOption "debug-info" configDebugInfo (\v flags -> flags { configDebugInfo = v }) [optArg' "n" (Flag . flagToDebugInfoLevel) (\f -> case f of Flag NoDebugInfo -> [] Flag MinimalDebugInfo -> [Just "1"] Flag NormalDebugInfo -> [Nothing] Flag MaximalDebugInfo -> [Just "3"] _ -> []) "" ["enable-debug-info"] "Emit debug info (n is 0--3, default is 0)", noArg (Flag NoDebugInfo) [] ["disable-debug-info"] "Don't emit debug info" ] ,option "" ["library-for-ghci"] "compile library for use with GHCi" configGHCiLib (\v flags -> flags { configGHCiLib = v }) (boolOpt [] []) ,option "" ["split-objs"] "split library into smaller objects to reduce binary sizes (GHC 6.6+)" configSplitObjs (\v flags -> flags { configSplitObjs = v }) (boolOpt [] []) ,option "" ["executable-stripping"] "strip executables upon installation to reduce binary sizes" configStripExes (\v flags -> flags { configStripExes = v }) (boolOpt [] []) ,option "" ["library-stripping"] "strip libraries upon installation to reduce binary sizes" configStripLibs (\v flags -> flags { configStripLibs = v }) (boolOpt [] []) ,option "" ["configure-option"] "Extra option for configure" configConfigureArgs (\v flags -> flags { configConfigureArgs = v }) (reqArg' "OPT" (\x -> [x]) id) ,option "" ["user-install"] "doing a per-user installation" configUserInstall (\v flags -> flags { configUserInstall = v }) (boolOpt' ([],["user"]) ([], ["global"])) ,option "" ["package-db"] "Use a given package database (to satisfy dependencies and register in). May be a specific file, 'global', 'user' or 'clear'." configPackageDBs (\v flags -> flags { configPackageDBs = v }) (reqArg' "DB" readPackageDbList showPackageDbList) ,option "f" ["flags"] "Force values for the given flags in Cabal conditionals in the .cabal file. E.g., --flags=\"debug -usebytestrings\" forces the flag \"debug\" to true and \"usebytestrings\" to false." configConfigurationsFlags (\v flags -> flags { configConfigurationsFlags = v }) (reqArg' "FLAGS" readFlagList showFlagList) ,option "" ["extra-include-dirs"] "A list of directories to search for header files" configExtraIncludeDirs (\v flags -> flags {configExtraIncludeDirs = v}) (reqArg' "PATH" (\x -> [x]) id) ,option "" ["extra-lib-dirs"] "A list of directories to search for external libraries" configExtraLibDirs (\v flags -> flags {configExtraLibDirs = v}) (reqArg' "PATH" (\x -> [x]) id) ,option "" ["extra-prog-path"] "A list of directories to search for required programs (in addition to the normal search locations)" configProgramPathExtra (\v flags -> flags {configProgramPathExtra = v}) (reqArg' "PATH" (\x -> toNubList [x]) fromNubList) ,option "" ["constraint"] "A list of additional constraints on the dependencies." configConstraints (\v flags -> flags { configConstraints = v}) (reqArg "DEPENDENCY" (readP_to_E (const "dependency expected") ((\x -> [x]) `fmap` parse)) (map (\x -> display x))) ,option "" ["dependency"] "A list of exact dependencies. E.g., --dependency=\"void=void-0.5.8-177d5cdf20962d0581fe2e4932a6c309\"" configDependencies (\v flags -> flags { configDependencies = v}) (reqArg "NAME=ID" (readP_to_E (const "dependency expected") ((\x -> [x]) `fmap` parseDependency)) (map (\x -> display (fst x) ++ "=" ++ display (snd x)))) ,option "" ["instantiate-with"] "A mapping of signature names to concrete module instantiations. E.g., --instantiate-with=\"Map=Data.Map.Strict@containers-0.5.5.1-inplace\"" configInstantiateWith (\v flags -> flags { configInstantiateWith = v }) (reqArg "NAME=PKG:MOD" (readP_to_E (const "signature mapping expected") ((\x -> [x]) `fmap` parseHoleMapEntry)) (map (\(n,(p,m)) -> display n ++ "=" ++ display m ++ "@" ++ display p))) ,option "" ["tests"] "dependency checking and compilation for test suites listed in the package description file." configTests (\v flags -> flags { configTests = v }) (boolOpt [] []) ,option "" ["coverage"] "build package with Haskell Program Coverage. (GHC only)" configCoverage (\v flags -> flags { configCoverage = v }) (boolOpt [] []) ,option "" ["library-coverage"] "build package with Haskell Program Coverage. (GHC only) (DEPRECATED)" configLibCoverage (\v flags -> flags { configLibCoverage = v }) (boolOpt [] []) ,option "" ["exact-configuration"] "All direct dependencies and flags are provided on the command line." configExactConfiguration (\v flags -> flags { configExactConfiguration = v }) trueArg ,option "" ["benchmarks"] "dependency checking and compilation for benchmarks listed in the package description file." configBenchmarks (\v flags -> flags { configBenchmarks = v }) (boolOpt [] []) ,option "" ["relocatable"] "building a package that is relocatable. (GHC only)" configRelocatable (\v flags -> flags { configRelocatable = v}) (boolOpt [] []) ] where readFlagList :: String -> FlagAssignment readFlagList = map tagWithValue . words where tagWithValue ('-':fname) = (FlagName (lowercase fname), False) tagWithValue fname = (FlagName (lowercase fname), True) showFlagList :: FlagAssignment -> [String] showFlagList fs = [ if not set then '-':fname else fname | (FlagName fname, set) <- fs] liftInstallDirs = liftOption configInstallDirs (\v flags -> flags { configInstallDirs = v }) reqPathTemplateArgFlag title _sf _lf d get set = reqArgFlag title _sf _lf d (fmap fromPathTemplate . get) (set . fmap toPathTemplate) readPackageDbList :: String -> [Maybe PackageDB] readPackageDbList "clear" = [Nothing] readPackageDbList "global" = [Just GlobalPackageDB] readPackageDbList "user" = [Just UserPackageDB] readPackageDbList other = [Just (SpecificPackageDB other)] showPackageDbList :: [Maybe PackageDB] -> [String] showPackageDbList = map showPackageDb where showPackageDb Nothing = "clear" showPackageDb (Just GlobalPackageDB) = "global" showPackageDb (Just UserPackageDB) = "user" showPackageDb (Just (SpecificPackageDB db)) = db parseDependency :: Parse.ReadP r (PackageName, InstalledPackageId) parseDependency = do x <- parse _ <- Parse.char '=' y <- parse return (x, y) parseHoleMapEntry :: Parse.ReadP r (ModuleName, (InstalledPackageId, ModuleName)) parseHoleMapEntry = do x <- parse _ <- Parse.char '=' y <- parse _ <- Parse.char '@' z <- parse return (x, (z, y)) installDirsOptions :: [OptionField (InstallDirs (Flag PathTemplate))] installDirsOptions = [ option "" ["prefix"] "bake this prefix in preparation of installation" prefix (\v flags -> flags { prefix = v }) installDirArg , option "" ["bindir"] "installation directory for executables" bindir (\v flags -> flags { bindir = v }) installDirArg , option "" ["libdir"] "installation directory for libraries" libdir (\v flags -> flags { libdir = v }) installDirArg , option "" ["libsubdir"] "subdirectory of libdir in which libs are installed" libsubdir (\v flags -> flags { libsubdir = v }) installDirArg , option "" ["libexecdir"] "installation directory for program executables" libexecdir (\v flags -> flags { libexecdir = v }) installDirArg , option "" ["datadir"] "installation directory for read-only data" datadir (\v flags -> flags { datadir = v }) installDirArg , option "" ["datasubdir"] "subdirectory of datadir in which data files are installed" datasubdir (\v flags -> flags { datasubdir = v }) installDirArg , option "" ["docdir"] "installation directory for documentation" docdir (\v flags -> flags { docdir = v }) installDirArg , option "" ["htmldir"] "installation directory for HTML documentation" htmldir (\v flags -> flags { htmldir = v }) installDirArg , option "" ["haddockdir"] "installation directory for haddock interfaces" haddockdir (\v flags -> flags { haddockdir = v }) installDirArg , option "" ["sysconfdir"] "installation directory for configuration files" sysconfdir (\v flags -> flags { sysconfdir = v }) installDirArg ] where installDirArg _sf _lf d get set = reqArgFlag "DIR" _sf _lf d (fmap fromPathTemplate . get) (set . fmap toPathTemplate) emptyConfigFlags :: ConfigFlags emptyConfigFlags = mempty instance Monoid ConfigFlags where mempty = ConfigFlags { configPrograms = error "FIXME: remove configPrograms", configProgramPaths = mempty, configProgramArgs = mempty, configProgramPathExtra = mempty, configHcFlavor = mempty, configHcPath = mempty, configHcPkg = mempty, configVanillaLib = mempty, configProfLib = mempty, configSharedLib = mempty, configDynExe = mempty, configProfExe = mempty, configConfigureArgs = mempty, configOptimization = mempty, configProgPrefix = mempty, configProgSuffix = mempty, configInstallDirs = mempty, configScratchDir = mempty, configDistPref = mempty, configVerbosity = mempty, configUserInstall = mempty, configPackageDBs = mempty, configGHCiLib = mempty, configSplitObjs = mempty, configStripExes = mempty, configStripLibs = mempty, configExtraLibDirs = mempty, configConstraints = mempty, configDependencies = mempty, configInstantiateWith = mempty, configExtraIncludeDirs = mempty, configConfigurationsFlags = mempty, configTests = mempty, configCoverage = mempty, configLibCoverage = mempty, configExactConfiguration = mempty, configBenchmarks = mempty, configFlagError = mempty, configRelocatable = mempty, configDebugInfo = mempty } mappend a b = ConfigFlags { configPrograms = configPrograms b, configProgramPaths = combine configProgramPaths, configProgramArgs = combine configProgramArgs, configProgramPathExtra = combine configProgramPathExtra, configHcFlavor = combine configHcFlavor, configHcPath = combine configHcPath, configHcPkg = combine configHcPkg, configVanillaLib = combine configVanillaLib, configProfLib = combine configProfLib, configSharedLib = combine configSharedLib, configDynExe = combine configDynExe, configProfExe = combine configProfExe, configConfigureArgs = combine configConfigureArgs, configOptimization = combine configOptimization, configProgPrefix = combine configProgPrefix, configProgSuffix = combine configProgSuffix, configInstallDirs = combine configInstallDirs, configScratchDir = combine configScratchDir, configDistPref = combine configDistPref, configVerbosity = combine configVerbosity, configUserInstall = combine configUserInstall, configPackageDBs = combine configPackageDBs, configGHCiLib = combine configGHCiLib, configSplitObjs = combine configSplitObjs, configStripExes = combine configStripExes, configStripLibs = combine configStripLibs, configExtraLibDirs = combine configExtraLibDirs, configConstraints = combine configConstraints, configDependencies = combine configDependencies, configInstantiateWith = combine configInstantiateWith, configExtraIncludeDirs = combine configExtraIncludeDirs, configConfigurationsFlags = combine configConfigurationsFlags, configTests = combine configTests, configCoverage = combine configCoverage, configLibCoverage = combine configLibCoverage, configExactConfiguration = combine configExactConfiguration, configBenchmarks = combine configBenchmarks, configFlagError = combine configFlagError, configRelocatable = combine configRelocatable, configDebugInfo = combine configDebugInfo } where combine field = field a `mappend` field b -- ------------------------------------------------------------ -- * Copy flags -- ------------------------------------------------------------ -- | Flags to @copy@: (destdir, copy-prefix (backwards compat), verbosity) data CopyFlags = CopyFlags { copyDest :: Flag CopyDest, copyDistPref :: Flag FilePath, copyVerbosity :: Flag Verbosity } deriving Show defaultCopyFlags :: CopyFlags defaultCopyFlags = CopyFlags { copyDest = Flag NoCopyDest, copyDistPref = Flag defaultDistPref, copyVerbosity = Flag normal } copyCommand :: CommandUI CopyFlags copyCommand = CommandUI { commandName = "copy" , commandSynopsis = "Copy the files into the install locations." , commandDescription = Just $ \_ -> wrapText $ "Does not call register, and allows a prefix at install time. " ++ "Without the --destdir flag, configure determines location.\n" , commandNotes = Nothing , commandUsage = \pname -> "Usage: " ++ pname ++ " copy [FLAGS]\n" , commandDefaultFlags = defaultCopyFlags , commandOptions = \showOrParseArgs -> [optionVerbosity copyVerbosity (\v flags -> flags { copyVerbosity = v }) ,optionDistPref copyDistPref (\d flags -> flags { copyDistPref = d }) showOrParseArgs ,option "" ["destdir"] "directory to copy files to, prepended to installation directories" copyDest (\v flags -> flags { copyDest = v }) (reqArg "DIR" (succeedReadE (Flag . CopyTo)) (\f -> case f of Flag (CopyTo p) -> [p]; _ -> [])) ] } emptyCopyFlags :: CopyFlags emptyCopyFlags = mempty instance Monoid CopyFlags where mempty = CopyFlags { copyDest = mempty, copyDistPref = mempty, copyVerbosity = mempty } mappend a b = CopyFlags { copyDest = combine copyDest, copyDistPref = combine copyDistPref, copyVerbosity = combine copyVerbosity } where combine field = field a `mappend` field b -- ------------------------------------------------------------ -- * Install flags -- ------------------------------------------------------------ -- | Flags to @install@: (package db, verbosity) data InstallFlags = InstallFlags { installPackageDB :: Flag PackageDB, installDistPref :: Flag FilePath, installUseWrapper :: Flag Bool, installInPlace :: Flag Bool, installVerbosity :: Flag Verbosity } deriving Show defaultInstallFlags :: InstallFlags defaultInstallFlags = InstallFlags { installPackageDB = NoFlag, installDistPref = Flag defaultDistPref, installUseWrapper = Flag False, installInPlace = Flag False, installVerbosity = Flag normal } installCommand :: CommandUI InstallFlags installCommand = CommandUI { commandName = "install" , commandSynopsis = "Copy the files into the install locations. Run register." , commandDescription = Just $ \_ -> wrapText $ "Unlike the copy command, install calls the register command." ++ "If you want to install into a location that is not what was" ++ "specified in the configure step, use the copy command.\n" , commandNotes = Nothing , commandUsage = \pname -> "Usage: " ++ pname ++ " install [FLAGS]\n" , commandDefaultFlags = defaultInstallFlags , commandOptions = \showOrParseArgs -> [optionVerbosity installVerbosity (\v flags -> flags { installVerbosity = v }) ,optionDistPref installDistPref (\d flags -> flags { installDistPref = d }) showOrParseArgs ,option "" ["inplace"] "install the package in the install subdirectory of the dist prefix, so it can be used without being installed" installInPlace (\v flags -> flags { installInPlace = v }) trueArg ,option "" ["shell-wrappers"] "using shell script wrappers around executables" installUseWrapper (\v flags -> flags { installUseWrapper = v }) (boolOpt [] []) ,option "" ["package-db"] "" installPackageDB (\v flags -> flags { installPackageDB = v }) (choiceOpt [ (Flag UserPackageDB, ([],["user"]), "upon configuration register this package in the user's local package database") , (Flag GlobalPackageDB, ([],["global"]), "(default) upon configuration register this package in the system-wide package database")]) ] } emptyInstallFlags :: InstallFlags emptyInstallFlags = mempty instance Monoid InstallFlags where mempty = InstallFlags{ installPackageDB = mempty, installDistPref = mempty, installUseWrapper = mempty, installInPlace = mempty, installVerbosity = mempty } mappend a b = InstallFlags{ installPackageDB = combine installPackageDB, installDistPref = combine installDistPref, installUseWrapper = combine installUseWrapper, installInPlace = combine installInPlace, installVerbosity = combine installVerbosity } where combine field = field a `mappend` field b -- ------------------------------------------------------------ -- * SDist flags -- ------------------------------------------------------------ -- | Flags to @sdist@: (snapshot, verbosity) data SDistFlags = SDistFlags { sDistSnapshot :: Flag Bool, sDistDirectory :: Flag FilePath, sDistDistPref :: Flag FilePath, sDistListSources :: Flag FilePath, sDistVerbosity :: Flag Verbosity } deriving Show defaultSDistFlags :: SDistFlags defaultSDistFlags = SDistFlags { sDistSnapshot = Flag False, sDistDirectory = mempty, sDistDistPref = Flag defaultDistPref, sDistListSources = mempty, sDistVerbosity = Flag normal } sdistCommand :: CommandUI SDistFlags sdistCommand = CommandUI { commandName = "sdist" , commandSynopsis = "Generate a source distribution file (.tar.gz)." , commandDescription = Nothing , commandNotes = Nothing , commandUsage = \pname -> "Usage: " ++ pname ++ " sdist [FLAGS]\n" , commandDefaultFlags = defaultSDistFlags , commandOptions = \showOrParseArgs -> [optionVerbosity sDistVerbosity (\v flags -> flags { sDistVerbosity = v }) ,optionDistPref sDistDistPref (\d flags -> flags { sDistDistPref = d }) showOrParseArgs ,option "" ["list-sources"] "Just write a list of the package's sources to a file" sDistListSources (\v flags -> flags { sDistListSources = v }) (reqArgFlag "FILE") ,option "" ["snapshot"] "Produce a snapshot source distribution" sDistSnapshot (\v flags -> flags { sDistSnapshot = v }) trueArg ,option "" ["output-directory"] ("Generate a source distribution in the given directory, " ++ "without creating a tarball") sDistDirectory (\v flags -> flags { sDistDirectory = v }) (reqArgFlag "DIR") ] } emptySDistFlags :: SDistFlags emptySDistFlags = mempty instance Monoid SDistFlags where mempty = SDistFlags { sDistSnapshot = mempty, sDistDirectory = mempty, sDistDistPref = mempty, sDistListSources = mempty, sDistVerbosity = mempty } mappend a b = SDistFlags { sDistSnapshot = combine sDistSnapshot, sDistDirectory = combine sDistDirectory, sDistDistPref = combine sDistDistPref, sDistListSources = combine sDistListSources, sDistVerbosity = combine sDistVerbosity } where combine field = field a `mappend` field b -- ------------------------------------------------------------ -- * Register flags -- ------------------------------------------------------------ -- | Flags to @register@ and @unregister@: (user package, gen-script, -- in-place, verbosity) data RegisterFlags = RegisterFlags { regPackageDB :: Flag PackageDB, regGenScript :: Flag Bool, regGenPkgConf :: Flag (Maybe FilePath), regInPlace :: Flag Bool, regDistPref :: Flag FilePath, regPrintId :: Flag Bool, regVerbosity :: Flag Verbosity } deriving Show defaultRegisterFlags :: RegisterFlags defaultRegisterFlags = RegisterFlags { regPackageDB = NoFlag, regGenScript = Flag False, regGenPkgConf = NoFlag, regInPlace = Flag False, regDistPref = Flag defaultDistPref, regPrintId = Flag False, regVerbosity = Flag normal } registerCommand :: CommandUI RegisterFlags registerCommand = CommandUI { commandName = "register" , commandSynopsis = "Register this package with the compiler." , commandDescription = Nothing , commandNotes = Nothing , commandUsage = \pname -> "Usage: " ++ pname ++ " register [FLAGS]\n" , commandDefaultFlags = defaultRegisterFlags , commandOptions = \showOrParseArgs -> [optionVerbosity regVerbosity (\v flags -> flags { regVerbosity = v }) ,optionDistPref regDistPref (\d flags -> flags { regDistPref = d }) showOrParseArgs ,option "" ["packageDB"] "" regPackageDB (\v flags -> flags { regPackageDB = v }) (choiceOpt [ (Flag UserPackageDB, ([],["user"]), "upon registration, register this package in the user's local package database") , (Flag GlobalPackageDB, ([],["global"]), "(default)upon registration, register this package in the system-wide package database")]) ,option "" ["inplace"] "register the package in the build location, so it can be used without being installed" regInPlace (\v flags -> flags { regInPlace = v }) trueArg ,option "" ["gen-script"] "instead of registering, generate a script to register later" regGenScript (\v flags -> flags { regGenScript = v }) trueArg ,option "" ["gen-pkg-config"] "instead of registering, generate a package registration file" regGenPkgConf (\v flags -> flags { regGenPkgConf = v }) (optArg' "PKG" Flag flagToList) ,option "" ["print-ipid"] "print the installed package ID calculated for this package" regPrintId (\v flags -> flags { regPrintId = v }) trueArg ] } unregisterCommand :: CommandUI RegisterFlags unregisterCommand = CommandUI { commandName = "unregister" , commandSynopsis = "Unregister this package with the compiler." , commandDescription = Nothing , commandNotes = Nothing , commandUsage = \pname -> "Usage: " ++ pname ++ " unregister [FLAGS]\n" , commandDefaultFlags = defaultRegisterFlags , commandOptions = \showOrParseArgs -> [optionVerbosity regVerbosity (\v flags -> flags { regVerbosity = v }) ,optionDistPref regDistPref (\d flags -> flags { regDistPref = d }) showOrParseArgs ,option "" ["user"] "" regPackageDB (\v flags -> flags { regPackageDB = v }) (choiceOpt [ (Flag UserPackageDB, ([],["user"]), "unregister this package in the user's local package database") , (Flag GlobalPackageDB, ([],["global"]), "(default) unregister this package in the system-wide package database")]) ,option "" ["gen-script"] "Instead of performing the unregister command, generate a script to unregister later" regGenScript (\v flags -> flags { regGenScript = v }) trueArg ] } emptyRegisterFlags :: RegisterFlags emptyRegisterFlags = mempty instance Monoid RegisterFlags where mempty = RegisterFlags { regPackageDB = mempty, regGenScript = mempty, regGenPkgConf = mempty, regInPlace = mempty, regPrintId = mempty, regDistPref = mempty, regVerbosity = mempty } mappend a b = RegisterFlags { regPackageDB = combine regPackageDB, regGenScript = combine regGenScript, regGenPkgConf = combine regGenPkgConf, regInPlace = combine regInPlace, regPrintId = combine regPrintId, regDistPref = combine regDistPref, regVerbosity = combine regVerbosity } where combine field = field a `mappend` field b -- ------------------------------------------------------------ -- * HsColour flags -- ------------------------------------------------------------ data HscolourFlags = HscolourFlags { hscolourCSS :: Flag FilePath, hscolourExecutables :: Flag Bool, hscolourTestSuites :: Flag Bool, hscolourBenchmarks :: Flag Bool, hscolourDistPref :: Flag FilePath, hscolourVerbosity :: Flag Verbosity } deriving Show emptyHscolourFlags :: HscolourFlags emptyHscolourFlags = mempty defaultHscolourFlags :: HscolourFlags defaultHscolourFlags = HscolourFlags { hscolourCSS = NoFlag, hscolourExecutables = Flag False, hscolourTestSuites = Flag False, hscolourBenchmarks = Flag False, hscolourDistPref = Flag defaultDistPref, hscolourVerbosity = Flag normal } instance Monoid HscolourFlags where mempty = HscolourFlags { hscolourCSS = mempty, hscolourExecutables = mempty, hscolourTestSuites = mempty, hscolourBenchmarks = mempty, hscolourDistPref = mempty, hscolourVerbosity = mempty } mappend a b = HscolourFlags { hscolourCSS = combine hscolourCSS, hscolourExecutables = combine hscolourExecutables, hscolourTestSuites = combine hscolourTestSuites, hscolourBenchmarks = combine hscolourBenchmarks, hscolourDistPref = combine hscolourDistPref, hscolourVerbosity = combine hscolourVerbosity } where combine field = field a `mappend` field b hscolourCommand :: CommandUI HscolourFlags hscolourCommand = CommandUI { commandName = "hscolour" , commandSynopsis = "Generate HsColour colourised code, in HTML format." , commandDescription = Just (\_ -> "Requires the hscolour program.\n") , commandNotes = Nothing , commandUsage = \pname -> "Usage: " ++ pname ++ " hscolour [FLAGS]\n" , commandDefaultFlags = defaultHscolourFlags , commandOptions = \showOrParseArgs -> [optionVerbosity hscolourVerbosity (\v flags -> flags { hscolourVerbosity = v }) ,optionDistPref hscolourDistPref (\d flags -> flags { hscolourDistPref = d }) showOrParseArgs ,option "" ["executables"] "Run hscolour for Executables targets" hscolourExecutables (\v flags -> flags { hscolourExecutables = v }) trueArg ,option "" ["tests"] "Run hscolour for Test Suite targets" hscolourTestSuites (\v flags -> flags { hscolourTestSuites = v }) trueArg ,option "" ["benchmarks"] "Run hscolour for Benchmark targets" hscolourBenchmarks (\v flags -> flags { hscolourBenchmarks = v }) trueArg ,option "" ["all"] "Run hscolour for all targets" (\f -> allFlags [ hscolourExecutables f , hscolourTestSuites f , hscolourBenchmarks f]) (\v flags -> flags { hscolourExecutables = v , hscolourTestSuites = v , hscolourBenchmarks = v }) trueArg ,option "" ["css"] "Use a cascading style sheet" hscolourCSS (\v flags -> flags { hscolourCSS = v }) (reqArgFlag "PATH") ] } -- ------------------------------------------------------------ -- * Haddock flags -- ------------------------------------------------------------ data HaddockFlags = HaddockFlags { haddockProgramPaths :: [(String, FilePath)], haddockProgramArgs :: [(String, [String])], haddockHoogle :: Flag Bool, haddockHtml :: Flag Bool, haddockHtmlLocation :: Flag String, haddockExecutables :: Flag Bool, haddockTestSuites :: Flag Bool, haddockBenchmarks :: Flag Bool, haddockInternal :: Flag Bool, haddockCss :: Flag FilePath, haddockHscolour :: Flag Bool, haddockHscolourCss :: Flag FilePath, haddockContents :: Flag PathTemplate, haddockDistPref :: Flag FilePath, haddockKeepTempFiles:: Flag Bool, haddockVerbosity :: Flag Verbosity } deriving Show defaultHaddockFlags :: HaddockFlags defaultHaddockFlags = HaddockFlags { haddockProgramPaths = mempty, haddockProgramArgs = [], haddockHoogle = Flag False, haddockHtml = Flag False, haddockHtmlLocation = NoFlag, haddockExecutables = Flag False, haddockTestSuites = Flag False, haddockBenchmarks = Flag False, haddockInternal = Flag False, haddockCss = NoFlag, haddockHscolour = Flag False, haddockHscolourCss = NoFlag, haddockContents = NoFlag, haddockDistPref = Flag defaultDistPref, haddockKeepTempFiles= Flag False, haddockVerbosity = Flag normal } haddockCommand :: CommandUI HaddockFlags haddockCommand = CommandUI { commandName = "haddock" , commandSynopsis = "Generate Haddock HTML documentation." , commandDescription = Just $ \_ -> "Requires the program haddock, version 2.x.\n" , commandNotes = Nothing , commandUsage = \pname -> "Usage: " ++ pname ++ " haddock [FLAGS]\n" , commandDefaultFlags = defaultHaddockFlags , commandOptions = \showOrParseArgs -> haddockOptions showOrParseArgs ++ programConfigurationPaths progConf ParseArgs haddockProgramPaths (\v flags -> flags { haddockProgramPaths = v}) ++ programConfigurationOption progConf showOrParseArgs haddockProgramArgs (\v fs -> fs { haddockProgramArgs = v }) ++ programConfigurationOptions progConf ParseArgs haddockProgramArgs (\v flags -> flags { haddockProgramArgs = v}) } where progConf = addKnownProgram haddockProgram $ addKnownProgram ghcProgram $ emptyProgramConfiguration haddockOptions :: ShowOrParseArgs -> [OptionField HaddockFlags] haddockOptions showOrParseArgs = [optionVerbosity haddockVerbosity (\v flags -> flags { haddockVerbosity = v }) ,optionDistPref haddockDistPref (\d flags -> flags { haddockDistPref = d }) showOrParseArgs ,option "" ["keep-temp-files"] "Keep temporary files" haddockKeepTempFiles (\b flags -> flags { haddockKeepTempFiles = b }) trueArg ,option "" ["hoogle"] "Generate a hoogle database" haddockHoogle (\v flags -> flags { haddockHoogle = v }) trueArg ,option "" ["html"] "Generate HTML documentation (the default)" haddockHtml (\v flags -> flags { haddockHtml = v }) trueArg ,option "" ["html-location"] "Location of HTML documentation for pre-requisite packages" haddockHtmlLocation (\v flags -> flags { haddockHtmlLocation = v }) (reqArgFlag "URL") ,option "" ["executables"] "Run haddock for Executables targets" haddockExecutables (\v flags -> flags { haddockExecutables = v }) trueArg ,option "" ["tests"] "Run haddock for Test Suite targets" haddockTestSuites (\v flags -> flags { haddockTestSuites = v }) trueArg ,option "" ["benchmarks"] "Run haddock for Benchmark targets" haddockBenchmarks (\v flags -> flags { haddockBenchmarks = v }) trueArg ,option "" ["all"] "Run haddock for all targets" (\f -> allFlags [ haddockExecutables f , haddockTestSuites f , haddockBenchmarks f]) (\v flags -> flags { haddockExecutables = v , haddockTestSuites = v , haddockBenchmarks = v }) trueArg ,option "" ["internal"] "Run haddock for internal modules and include all symbols" haddockInternal (\v flags -> flags { haddockInternal = v }) trueArg ,option "" ["css"] "Use PATH as the haddock stylesheet" haddockCss (\v flags -> flags { haddockCss = v }) (reqArgFlag "PATH") ,option "" ["hyperlink-source","hyperlink-sources"] "Hyperlink the documentation to the source code (using HsColour)" haddockHscolour (\v flags -> flags { haddockHscolour = v }) trueArg ,option "" ["hscolour-css"] "Use PATH as the HsColour stylesheet" haddockHscolourCss (\v flags -> flags { haddockHscolourCss = v }) (reqArgFlag "PATH") ,option "" ["contents-location"] "Bake URL in as the location for the contents page" haddockContents (\v flags -> flags { haddockContents = v }) (reqArg' "URL" (toFlag . toPathTemplate) (flagToList . fmap fromPathTemplate)) ] emptyHaddockFlags :: HaddockFlags emptyHaddockFlags = mempty instance Monoid HaddockFlags where mempty = HaddockFlags { haddockProgramPaths = mempty, haddockProgramArgs = mempty, haddockHoogle = mempty, haddockHtml = mempty, haddockHtmlLocation = mempty, haddockExecutables = mempty, haddockTestSuites = mempty, haddockBenchmarks = mempty, haddockInternal = mempty, haddockCss = mempty, haddockHscolour = mempty, haddockHscolourCss = mempty, haddockContents = mempty, haddockDistPref = mempty, haddockKeepTempFiles= mempty, haddockVerbosity = mempty } mappend a b = HaddockFlags { haddockProgramPaths = combine haddockProgramPaths, haddockProgramArgs = combine haddockProgramArgs, haddockHoogle = combine haddockHoogle, haddockHtml = combine haddockHoogle, haddockHtmlLocation = combine haddockHtmlLocation, haddockExecutables = combine haddockExecutables, haddockTestSuites = combine haddockTestSuites, haddockBenchmarks = combine haddockBenchmarks, haddockInternal = combine haddockInternal, haddockCss = combine haddockCss, haddockHscolour = combine haddockHscolour, haddockHscolourCss = combine haddockHscolourCss, haddockContents = combine haddockContents, haddockDistPref = combine haddockDistPref, haddockKeepTempFiles= combine haddockKeepTempFiles, haddockVerbosity = combine haddockVerbosity } where combine field = field a `mappend` field b -- ------------------------------------------------------------ -- * Clean flags -- ------------------------------------------------------------ data CleanFlags = CleanFlags { cleanSaveConf :: Flag Bool, cleanDistPref :: Flag FilePath, cleanVerbosity :: Flag Verbosity } deriving Show defaultCleanFlags :: CleanFlags defaultCleanFlags = CleanFlags { cleanSaveConf = Flag False, cleanDistPref = Flag defaultDistPref, cleanVerbosity = Flag normal } cleanCommand :: CommandUI CleanFlags cleanCommand = CommandUI { commandName = "clean" , commandSynopsis = "Clean up after a build." , commandDescription = Just $ \_ -> "Removes .hi, .o, preprocessed sources, etc.\n" , commandNotes = Nothing , commandUsage = \pname -> "Usage: " ++ pname ++ " clean [FLAGS]\n" , commandDefaultFlags = defaultCleanFlags , commandOptions = \showOrParseArgs -> [optionVerbosity cleanVerbosity (\v flags -> flags { cleanVerbosity = v }) ,optionDistPref cleanDistPref (\d flags -> flags { cleanDistPref = d }) showOrParseArgs ,option "s" ["save-configure"] "Do not remove the configuration file (dist/setup-config) during cleaning. Saves need to reconfigure." cleanSaveConf (\v flags -> flags { cleanSaveConf = v }) trueArg ] } emptyCleanFlags :: CleanFlags emptyCleanFlags = mempty instance Monoid CleanFlags where mempty = CleanFlags { cleanSaveConf = mempty, cleanDistPref = mempty, cleanVerbosity = mempty } mappend a b = CleanFlags { cleanSaveConf = combine cleanSaveConf, cleanDistPref = combine cleanDistPref, cleanVerbosity = combine cleanVerbosity } where combine field = field a `mappend` field b -- ------------------------------------------------------------ -- * Build flags -- ------------------------------------------------------------ data BuildFlags = BuildFlags { buildProgramPaths :: [(String, FilePath)], buildProgramArgs :: [(String, [String])], buildDistPref :: Flag FilePath, buildVerbosity :: Flag Verbosity, buildNumJobs :: Flag (Maybe Int), -- TODO: this one should not be here, it's just that the silly -- UserHooks stop us from passing extra info in other ways buildArgs :: [String] } deriving Show {-# DEPRECATED buildVerbose "Use buildVerbosity instead" #-} buildVerbose :: BuildFlags -> Verbosity buildVerbose = fromFlagOrDefault normal . buildVerbosity defaultBuildFlags :: BuildFlags defaultBuildFlags = BuildFlags { buildProgramPaths = mempty, buildProgramArgs = [], buildDistPref = Flag defaultDistPref, buildVerbosity = Flag normal, buildNumJobs = mempty, buildArgs = [] } buildCommand :: ProgramConfiguration -> CommandUI BuildFlags buildCommand progConf = CommandUI { commandName = "build" , commandSynopsis = "Compile all/specific components." , commandDescription = Just $ \_ -> wrapText $ "Components encompass executables, tests, and benchmarks.\n" ++ "\n" ++ "Affected by configuration options, see `configure`.\n" , commandNotes = Just $ \pname -> "Examples:\n" ++ " " ++ pname ++ " build " ++ " All the components in the package\n" ++ " " ++ pname ++ " build foo " ++ " A component (i.e. lib, exe, test suite)\n\n" ++ programFlagsDescription progConf --TODO: re-enable once we have support for module/file targets -- ++ " " ++ pname ++ " build Foo.Bar " -- ++ " A module\n" -- ++ " " ++ pname ++ " build Foo/Bar.hs" -- ++ " A file\n\n" -- ++ "If a target is ambiguous it can be qualified with the component " -- ++ "name, e.g.\n" -- ++ " " ++ pname ++ " build foo:Foo.Bar\n" -- ++ " " ++ pname ++ " build testsuite1:Foo/Bar.hs\n" , commandUsage = usageAlternatives "build" $ [ "[FLAGS]" , "COMPONENTS [FLAGS]" ] , commandDefaultFlags = defaultBuildFlags , commandOptions = \showOrParseArgs -> [ optionVerbosity buildVerbosity (\v flags -> flags { buildVerbosity = v }) , optionDistPref buildDistPref (\d flags -> flags { buildDistPref = d }) showOrParseArgs ] ++ buildOptions progConf showOrParseArgs } buildOptions :: ProgramConfiguration -> ShowOrParseArgs -> [OptionField BuildFlags] buildOptions progConf showOrParseArgs = [ optionNumJobs buildNumJobs (\v flags -> flags { buildNumJobs = v }) ] ++ programConfigurationPaths progConf showOrParseArgs buildProgramPaths (\v flags -> flags { buildProgramPaths = v}) ++ programConfigurationOption progConf showOrParseArgs buildProgramArgs (\v fs -> fs { buildProgramArgs = v }) ++ programConfigurationOptions progConf showOrParseArgs buildProgramArgs (\v flags -> flags { buildProgramArgs = v}) emptyBuildFlags :: BuildFlags emptyBuildFlags = mempty instance Monoid BuildFlags where mempty = BuildFlags { buildProgramPaths = mempty, buildProgramArgs = mempty, buildVerbosity = mempty, buildDistPref = mempty, buildNumJobs = mempty, buildArgs = mempty } mappend a b = BuildFlags { buildProgramPaths = combine buildProgramPaths, buildProgramArgs = combine buildProgramArgs, buildVerbosity = combine buildVerbosity, buildDistPref = combine buildDistPref, buildNumJobs = combine buildNumJobs, buildArgs = combine buildArgs } where combine field = field a `mappend` field b -- ------------------------------------------------------------ -- * REPL Flags -- ------------------------------------------------------------ data ReplFlags = ReplFlags { replProgramPaths :: [(String, FilePath)], replProgramArgs :: [(String, [String])], replDistPref :: Flag FilePath, replVerbosity :: Flag Verbosity, replReload :: Flag Bool } deriving Show defaultReplFlags :: ReplFlags defaultReplFlags = ReplFlags { replProgramPaths = mempty, replProgramArgs = [], replDistPref = Flag defaultDistPref, replVerbosity = Flag normal, replReload = Flag False } instance Monoid ReplFlags where mempty = ReplFlags { replProgramPaths = mempty, replProgramArgs = mempty, replVerbosity = mempty, replDistPref = mempty, replReload = mempty } mappend a b = ReplFlags { replProgramPaths = combine replProgramPaths, replProgramArgs = combine replProgramArgs, replVerbosity = combine replVerbosity, replDistPref = combine replDistPref, replReload = combine replReload } where combine field = field a `mappend` field b replCommand :: ProgramConfiguration -> CommandUI ReplFlags replCommand progConf = CommandUI { commandName = "repl" , commandSynopsis = "Open an interpreter session for the given component." , commandDescription = Just $ \pname -> wrapText $ "If the current directory contains no package, ignores COMPONENT " ++ "parameters and opens an interactive interpreter session; if a " ++ "sandbox is present, its package database will be used.\n" ++ "\n" ++ "Otherwise, (re)configures with the given or default flags, and " ++ "loads the interpreter with the relevant modules. For executables, " ++ "tests and benchmarks, loads the main module (and its " ++ "dependencies); for libraries all exposed/other modules.\n" ++ "\n" ++ "The default component is the library itself, or the executable " ++ "if that is the only component.\n" ++ "\n" ++ "Support for loading specific modules is planned but not " ++ "implemented yet. For certain scenarios, `" ++ pname ++ " exec -- ghci :l Foo` may be used instead. Note that `exec` will " ++ "not (re)configure and you will have to specify the location of " ++ "other modules, if required.\n" , commandNotes = Just $ \pname -> "Examples:\n" ++ " " ++ pname ++ " repl " ++ " The first component in the package\n" ++ " " ++ pname ++ " repl foo " ++ " A named component (i.e. lib, exe, test suite)\n" ++ " " ++ pname ++ " repl --ghc-options=\"-lstdc++\"" ++ " Specifying flags for interpreter\n" --TODO: re-enable once we have support for module/file targets -- ++ " " ++ pname ++ " repl Foo.Bar " -- ++ " A module\n" -- ++ " " ++ pname ++ " repl Foo/Bar.hs" -- ++ " A file\n\n" -- ++ "If a target is ambiguous it can be qualified with the component " -- ++ "name, e.g.\n" -- ++ " " ++ pname ++ " repl foo:Foo.Bar\n" -- ++ " " ++ pname ++ " repl testsuite1:Foo/Bar.hs\n" , commandUsage = \pname -> "Usage: " ++ pname ++ " repl [COMPONENT] [FLAGS]\n" , commandDefaultFlags = defaultReplFlags , commandOptions = \showOrParseArgs -> optionVerbosity replVerbosity (\v flags -> flags { replVerbosity = v }) : optionDistPref replDistPref (\d flags -> flags { replDistPref = d }) showOrParseArgs : programConfigurationPaths progConf showOrParseArgs replProgramPaths (\v flags -> flags { replProgramPaths = v}) ++ programConfigurationOption progConf showOrParseArgs replProgramArgs (\v flags -> flags { replProgramArgs = v}) ++ programConfigurationOptions progConf showOrParseArgs replProgramArgs (\v flags -> flags { replProgramArgs = v}) ++ case showOrParseArgs of ParseArgs -> [ option "" ["reload"] "Used from within an interpreter to update files." replReload (\v flags -> flags { replReload = v }) trueArg ] _ -> [] } -- ------------------------------------------------------------ -- * Test flags -- ------------------------------------------------------------ data TestShowDetails = Never | Failures | Always | Streaming deriving (Eq, Ord, Enum, Bounded, Show) knownTestShowDetails :: [TestShowDetails] knownTestShowDetails = [minBound..maxBound] instance Text TestShowDetails where disp = Disp.text . lowercase . show parse = maybe Parse.pfail return . classify =<< ident where ident = Parse.munch1 (\c -> isAlpha c || c == '_' || c == '-') classify str = lookup (lowercase str) enumMap enumMap :: [(String, TestShowDetails)] enumMap = [ (display x, x) | x <- knownTestShowDetails ] --TODO: do we need this instance? instance Monoid TestShowDetails where mempty = Never mappend a b = if a < b then b else a data TestFlags = TestFlags { testDistPref :: Flag FilePath, testVerbosity :: Flag Verbosity, testHumanLog :: Flag PathTemplate, testMachineLog :: Flag PathTemplate, testShowDetails :: Flag TestShowDetails, testKeepTix :: Flag Bool, -- TODO: think about if/how options are passed to test exes testOptions :: [PathTemplate] } defaultTestFlags :: TestFlags defaultTestFlags = TestFlags { testDistPref = Flag defaultDistPref, testVerbosity = Flag normal, testHumanLog = toFlag $ toPathTemplate $ "$pkgid-$test-suite.log", testMachineLog = toFlag $ toPathTemplate $ "$pkgid.log", testShowDetails = toFlag Failures, testKeepTix = toFlag False, testOptions = [] } testCommand :: CommandUI TestFlags testCommand = CommandUI { commandName = "test" , commandSynopsis = "Run all/specific tests in the test suite." , commandDescription = Just $ \pname -> wrapText $ "If necessary (re)configures with `--enable-tests` flag and builds" ++ " the test suite.\n" ++ "\n" ++ "Remember that the tests' dependencies must be installed if there" ++ " are additional ones; e.g. with `" ++ pname ++ " install --only-dependencies --enable-tests`.\n" ++ "\n" ++ "By defining UserHooks in a custom Setup.hs, the package can" ++ " define actions to be executed before and after running tests.\n" , commandNotes = Nothing , commandUsage = usageAlternatives "test" [ "[FLAGS]" , "TESTCOMPONENTS [FLAGS]" ] , commandDefaultFlags = defaultTestFlags , commandOptions = \showOrParseArgs -> [ optionVerbosity testVerbosity (\v flags -> flags { testVerbosity = v }) , optionDistPref testDistPref (\d flags -> flags { testDistPref = d }) showOrParseArgs , option [] ["log"] ("Log all test suite results to file (name template can use " ++ "$pkgid, $compiler, $os, $arch, $test-suite, $result)") testHumanLog (\v flags -> flags { testHumanLog = v }) (reqArg' "TEMPLATE" (toFlag . toPathTemplate) (flagToList . fmap fromPathTemplate)) , option [] ["machine-log"] ("Produce a machine-readable log file (name template can use " ++ "$pkgid, $compiler, $os, $arch, $result)") testMachineLog (\v flags -> flags { testMachineLog = v }) (reqArg' "TEMPLATE" (toFlag . toPathTemplate) (flagToList . fmap fromPathTemplate)) , option [] ["show-details"] ("'always': always show results of individual test cases. " ++ "'never': never show results of individual test cases. " ++ "'failures': show results of failing test cases. " ++ "'streaming': show results of test cases in real time.") testShowDetails (\v flags -> flags { testShowDetails = v }) (reqArg "FILTER" (readP_to_E (\_ -> "--show-details flag expects one of " ++ intercalate ", " (map display knownTestShowDetails)) (fmap toFlag parse)) (flagToList . fmap display)) , option [] ["keep-tix-files"] "keep .tix files for HPC between test runs" testKeepTix (\v flags -> flags { testKeepTix = v}) trueArg , option [] ["test-options"] ("give extra options to test executables " ++ "(name templates can use $pkgid, $compiler, " ++ "$os, $arch, $test-suite)") testOptions (\v flags -> flags { testOptions = v }) (reqArg' "TEMPLATES" (map toPathTemplate . splitArgs) (const [])) , option [] ["test-option"] ("give extra option to test executables " ++ "(no need to quote options containing spaces, " ++ "name template can use $pkgid, $compiler, " ++ "$os, $arch, $test-suite)") testOptions (\v flags -> flags { testOptions = v }) (reqArg' "TEMPLATE" (\x -> [toPathTemplate x]) (map fromPathTemplate)) ] } emptyTestFlags :: TestFlags emptyTestFlags = mempty instance Monoid TestFlags where mempty = TestFlags { testDistPref = mempty, testVerbosity = mempty, testHumanLog = mempty, testMachineLog = mempty, testShowDetails = mempty, testKeepTix = mempty, testOptions = mempty } mappend a b = TestFlags { testDistPref = combine testDistPref, testVerbosity = combine testVerbosity, testHumanLog = combine testHumanLog, testMachineLog = combine testMachineLog, testShowDetails = combine testShowDetails, testKeepTix = combine testKeepTix, testOptions = combine testOptions } where combine field = field a `mappend` field b -- ------------------------------------------------------------ -- * Benchmark flags -- ------------------------------------------------------------ data BenchmarkFlags = BenchmarkFlags { benchmarkDistPref :: Flag FilePath, benchmarkVerbosity :: Flag Verbosity, benchmarkOptions :: [PathTemplate] } defaultBenchmarkFlags :: BenchmarkFlags defaultBenchmarkFlags = BenchmarkFlags { benchmarkDistPref = Flag defaultDistPref, benchmarkVerbosity = Flag normal, benchmarkOptions = [] } benchmarkCommand :: CommandUI BenchmarkFlags benchmarkCommand = CommandUI { commandName = "bench" , commandSynopsis = "Run all/specific benchmarks." , commandDescription = Just $ \pname -> wrapText $ "If necessary (re)configures with `--enable-benchmarks` flag and" ++ " builds the benchmarks.\n" ++ "\n" ++ "Remember that the benchmarks' dependencies must be installed if" ++ " there are additional ones; e.g. with `" ++ pname ++ " install --only-dependencies --enable-benchmarks`.\n" ++ "\n" ++ "By defining UserHooks in a custom Setup.hs, the package can" ++ " define actions to be executed before and after running" ++ " benchmarks.\n" , commandNotes = Nothing , commandUsage = usageAlternatives "bench" [ "[FLAGS]" , "BENCHCOMPONENTS [FLAGS]" ] , commandDefaultFlags = defaultBenchmarkFlags , commandOptions = \showOrParseArgs -> [ optionVerbosity benchmarkVerbosity (\v flags -> flags { benchmarkVerbosity = v }) , optionDistPref benchmarkDistPref (\d flags -> flags { benchmarkDistPref = d }) showOrParseArgs , option [] ["benchmark-options"] ("give extra options to benchmark executables " ++ "(name templates can use $pkgid, $compiler, " ++ "$os, $arch, $benchmark)") benchmarkOptions (\v flags -> flags { benchmarkOptions = v }) (reqArg' "TEMPLATES" (map toPathTemplate . splitArgs) (const [])) , option [] ["benchmark-option"] ("give extra option to benchmark executables " ++ "(no need to quote options containing spaces, " ++ "name template can use $pkgid, $compiler, " ++ "$os, $arch, $benchmark)") benchmarkOptions (\v flags -> flags { benchmarkOptions = v }) (reqArg' "TEMPLATE" (\x -> [toPathTemplate x]) (map fromPathTemplate)) ] } emptyBenchmarkFlags :: BenchmarkFlags emptyBenchmarkFlags = mempty instance Monoid BenchmarkFlags where mempty = BenchmarkFlags { benchmarkDistPref = mempty, benchmarkVerbosity = mempty, benchmarkOptions = mempty } mappend a b = BenchmarkFlags { benchmarkDistPref = combine benchmarkDistPref, benchmarkVerbosity = combine benchmarkVerbosity, benchmarkOptions = combine benchmarkOptions } where combine field = field a `mappend` field b -- ------------------------------------------------------------ -- * Shared options utils -- ------------------------------------------------------------ programFlagsDescription :: ProgramConfiguration -> String programFlagsDescription progConf = "The flags --with-PROG and --PROG-option(s) can be used with" ++ " the following programs:" ++ (concatMap (\line -> "\n " ++ unwords line) . wrapLine 77 . sort) [ programName prog | (prog, _) <- knownPrograms progConf ] ++ "\n" -- | For each known program @PROG@ in 'progConf', produce a @with-PROG@ -- 'OptionField'. programConfigurationPaths :: ProgramConfiguration -> ShowOrParseArgs -> (flags -> [(String, FilePath)]) -> ([(String, FilePath)] -> (flags -> flags)) -> [OptionField flags] programConfigurationPaths progConf showOrParseArgs get set = programConfigurationPaths' ("with-" ++) progConf showOrParseArgs get set -- | Like 'programConfigurationPaths', but allows to customise the option name. programConfigurationPaths' :: (String -> String) -> ProgramConfiguration -> ShowOrParseArgs -> (flags -> [(String, FilePath)]) -> ([(String, FilePath)] -> (flags -> flags)) -> [OptionField flags] programConfigurationPaths' mkName progConf showOrParseArgs get set = case showOrParseArgs of -- we don't want a verbose help text list so we just show a generic one: ShowArgs -> [withProgramPath "PROG"] ParseArgs -> map (withProgramPath . programName . fst) (knownPrograms progConf) where withProgramPath prog = option "" [mkName prog] ("give the path to " ++ prog) get set (reqArg' "PATH" (\path -> [(prog, path)]) (\progPaths -> [ path | (prog', path) <- progPaths, prog==prog' ])) -- | For each known program @PROG@ in 'progConf', produce a @PROG-option@ -- 'OptionField'. programConfigurationOption :: ProgramConfiguration -> ShowOrParseArgs -> (flags -> [(String, [String])]) -> ([(String, [String])] -> (flags -> flags)) -> [OptionField flags] programConfigurationOption progConf showOrParseArgs get set = case showOrParseArgs of -- we don't want a verbose help text list so we just show a generic one: ShowArgs -> [programOption "PROG"] ParseArgs -> map (programOption . programName . fst) (knownPrograms progConf) where programOption prog = option "" [prog ++ "-option"] ("give an extra option to " ++ prog ++ " (no need to quote options containing spaces)") get set (reqArg' "OPT" (\arg -> [(prog, [arg])]) (\progArgs -> concat [ args | (prog', args) <- progArgs, prog==prog' ])) -- | For each known program @PROG@ in 'progConf', produce a @PROG-options@ -- 'OptionField'. programConfigurationOptions :: ProgramConfiguration -> ShowOrParseArgs -> (flags -> [(String, [String])]) -> ([(String, [String])] -> (flags -> flags)) -> [OptionField flags] programConfigurationOptions progConf showOrParseArgs get set = case showOrParseArgs of -- we don't want a verbose help text list so we just show a generic one: ShowArgs -> [programOptions "PROG"] ParseArgs -> map (programOptions . programName . fst) (knownPrograms progConf) where programOptions prog = option "" [prog ++ "-options"] ("give extra options to " ++ prog) get set (reqArg' "OPTS" (\args -> [(prog, splitArgs args)]) (const [])) -- ------------------------------------------------------------ -- * GetOpt Utils -- ------------------------------------------------------------ boolOpt :: SFlags -> SFlags -> MkOptDescr (a -> Flag Bool) (Flag Bool -> a -> a) a boolOpt = Command.boolOpt flagToMaybe Flag boolOpt' :: OptFlags -> OptFlags -> MkOptDescr (a -> Flag Bool) (Flag Bool -> a -> a) a boolOpt' = Command.boolOpt' flagToMaybe Flag trueArg, falseArg :: MkOptDescr (a -> Flag Bool) (Flag Bool -> a -> a) a trueArg sfT lfT = boolOpt' (sfT, lfT) ([], []) sfT lfT falseArg sfF lfF = boolOpt' ([], []) (sfF, lfF) sfF lfF reqArgFlag :: ArgPlaceHolder -> SFlags -> LFlags -> Description -> (b -> Flag String) -> (Flag String -> b -> b) -> OptDescr b reqArgFlag ad = reqArg ad (succeedReadE Flag) flagToList optionDistPref :: (flags -> Flag FilePath) -> (Flag FilePath -> flags -> flags) -> ShowOrParseArgs -> OptionField flags optionDistPref get set = \showOrParseArgs -> option "" (distPrefFlagName showOrParseArgs) ( "The directory where Cabal puts generated build files " ++ "(default " ++ defaultDistPref ++ ")") get set (reqArgFlag "DIR") where distPrefFlagName ShowArgs = ["builddir"] distPrefFlagName ParseArgs = ["builddir", "distdir", "distpref"] optionVerbosity :: (flags -> Flag Verbosity) -> (Flag Verbosity -> flags -> flags) -> OptionField flags optionVerbosity get set = option "v" ["verbose"] "Control verbosity (n is 0--3, default verbosity level is 1)" get set (optArg "n" (fmap Flag flagToVerbosity) (Flag verbose) -- default Value if no n is given (fmap (Just . showForCabal) . flagToList)) optionNumJobs :: (flags -> Flag (Maybe Int)) -> (Flag (Maybe Int) -> flags -> flags) -> OptionField flags optionNumJobs get set = option "j" ["jobs"] "Run NUM jobs simultaneously (or '$ncpus' if no NUM is given)." get set (optArg "NUM" (fmap Flag numJobsParser) (Flag Nothing) (map (Just . maybe "$ncpus" show) . flagToList)) where numJobsParser :: ReadE (Maybe Int) numJobsParser = ReadE $ \s -> case s of "$ncpus" -> Right Nothing _ -> case reads s of [(n, "")] | n < 1 -> Left "The number of jobs should be 1 or more." | n > 64 -> Left "You probably don't want that many jobs." | otherwise -> Right (Just n) _ -> Left "The jobs value should be a number or '$ncpus'" -- ------------------------------------------------------------ -- * Other Utils -- ------------------------------------------------------------ -- | Arguments to pass to a @configure@ script, e.g. generated by -- @autoconf@. configureArgs :: Bool -> ConfigFlags -> [String] configureArgs bcHack flags = hc_flag ++ optFlag "with-hc-pkg" configHcPkg ++ optFlag' "prefix" prefix ++ optFlag' "bindir" bindir ++ optFlag' "libdir" libdir ++ optFlag' "libexecdir" libexecdir ++ optFlag' "datadir" datadir ++ optFlag' "sysconfdir" sysconfdir ++ configConfigureArgs flags where hc_flag = case (configHcFlavor flags, configHcPath flags) of (_, Flag hc_path) -> [hc_flag_name ++ hc_path] (Flag hc, NoFlag) -> [hc_flag_name ++ display hc] (NoFlag,NoFlag) -> [] hc_flag_name --TODO kill off thic bc hack when defaultUserHooks is removed. | bcHack = "--with-hc=" | otherwise = "--with-compiler=" optFlag name config_field = case config_field flags of Flag p -> ["--" ++ name ++ "=" ++ p] NoFlag -> [] optFlag' name config_field = optFlag name (fmap fromPathTemplate . config_field . configInstallDirs) configureCCompiler :: Verbosity -> ProgramConfiguration -> IO (FilePath, [String]) configureCCompiler verbosity lbi = configureProg verbosity lbi gccProgram configureLinker :: Verbosity -> ProgramConfiguration -> IO (FilePath, [String]) configureLinker verbosity lbi = configureProg verbosity lbi ldProgram configureProg :: Verbosity -> ProgramConfiguration -> Program -> IO (FilePath, [String]) configureProg verbosity programConfig prog = do (p, _) <- requireProgram verbosity prog programConfig let pInv = programInvocation p [] return (progInvokePath pInv, progInvokeArgs pInv) -- | Helper function to split a string into a list of arguments. -- It's supposed to handle quoted things sensibly, eg: -- -- > splitArgs "--foo=\"C:\Program Files\Bar\" --baz" -- > = ["--foo=C:\Program Files\Bar", "--baz"] -- splitArgs :: String -> [String] splitArgs = space [] where space :: String -> String -> [String] space w [] = word w [] space w ( c :s) | isSpace c = word w (space [] s) space w ('"':s) = string w s space w s = nonstring w s string :: String -> String -> [String] string w [] = word w [] string w ('"':s) = space w s string w ( c :s) = string (c:w) s nonstring :: String -> String -> [String] nonstring w [] = word w [] nonstring w ('"':s) = string w s nonstring w ( c :s) = space (c:w) s word [] s = s word w s = reverse w : s -- The test cases kinda have to be rewritten from the ground up... :/ --hunitTests :: [Test] --hunitTests = -- let m = [("ghc", GHC), ("nhc98", NHC), ("hugs", Hugs)] -- (flags, commands', unkFlags, ers) -- = getOpt Permute options ["configure", "foobar", "--prefix=/foo", "--ghc", "--nhc98", "--hugs", "--with-compiler=/comp", "--unknown1", "--unknown2", "--install-prefix=/foo", "--user", "--global"] -- in [TestLabel "very basic option parsing" $ TestList [ -- "getOpt flags" ~: "failed" ~: -- [Prefix "/foo", GhcFlag, NhcFlag, HugsFlag, -- WithCompiler "/comp", InstPrefix "/foo", UserFlag, GlobalFlag] -- ~=? flags, -- "getOpt commands" ~: "failed" ~: ["configure", "foobar"] ~=? commands', -- "getOpt unknown opts" ~: "failed" ~: -- ["--unknown1", "--unknown2"] ~=? unkFlags, -- "getOpt errors" ~: "failed" ~: [] ~=? ers], -- -- TestLabel "test location of various compilers" $ TestList -- ["configure parsing for prefix and compiler flag" ~: "failed" ~: -- (Right (ConfigCmd (Just comp, Nothing, Just "/usr/local"), [])) -- ~=? (parseArgs ["--prefix=/usr/local", "--"++name, "configure"]) -- | (name, comp) <- m], -- -- TestLabel "find the package tool" $ TestList -- ["configure parsing for prefix comp flag, withcompiler" ~: "failed" ~: -- (Right (ConfigCmd (Just comp, Just "/foo/comp", Just "/usr/local"), [])) -- ~=? (parseArgs ["--prefix=/usr/local", "--"++name, -- "--with-compiler=/foo/comp", "configure"]) -- | (name, comp) <- m], -- -- TestLabel "simpler commands" $ TestList -- [flag ~: "failed" ~: (Right (flagCmd, [])) ~=? (parseArgs [flag]) -- | (flag, flagCmd) <- [("build", BuildCmd), -- ("install", InstallCmd Nothing False), -- ("sdist", SDistCmd), -- ("register", RegisterCmd False)] -- ] -- ] {- Testing ideas: * IO to look for hugs and hugs-pkg (which hugs, etc) * quickCheck to test permutations of arguments * what other options can we over-ride with a command-line flag? -} Cabal-1.22.5.0/Distribution/Simple/SrcDist.hs0000644000000000000000000004741212627136220016757 0ustar0000000000000000----------------------------------------------------------------------------- -- | -- Module : Distribution.Simple.SrcDist -- Copyright : Simon Marlow 2004 -- License : BSD3 -- -- Maintainer : cabal-devel@haskell.org -- Portability : portable -- -- This handles the @sdist@ command. The module exports an 'sdist' action but -- also some of the phases that make it up so that other tools can use just the -- bits they need. In particular the preparation of the tree of files to go -- into the source tarball is separated from actually building the source -- tarball. -- -- The 'createArchive' action uses the external @tar@ program and assumes that -- it accepts the @-z@ flag. Neither of these assumptions are valid on Windows. -- The 'sdist' action now also does some distribution QA checks. -- NOTE: FIX: we don't have a great way of testing this module, since -- we can't easily look inside a tarball once its created. module Distribution.Simple.SrcDist ( -- * The top level action sdist, -- ** Parts of 'sdist' printPackageProblems, prepareTree, createArchive, -- ** Snapshots prepareSnapshotTree, snapshotPackage, snapshotVersion, dateToSnapshotNumber, -- * Extracting the source files listPackageSources ) where import Distribution.PackageDescription ( PackageDescription(..), BuildInfo(..), Executable(..), Library(..) , TestSuite(..), TestSuiteInterface(..), Benchmark(..) , BenchmarkInterface(..) ) import Distribution.PackageDescription.Check ( PackageCheck(..), checkConfiguredPackage, checkPackageFiles ) import Distribution.Package ( PackageIdentifier(pkgVersion), Package(..), packageVersion ) import Distribution.ModuleName (ModuleName) import qualified Distribution.ModuleName as ModuleName import Distribution.Version ( Version(versionBranch) ) import Distribution.Simple.Utils ( createDirectoryIfMissingVerbose, withUTF8FileContents, writeUTF8File , installOrdinaryFiles, installMaybeExecutableFiles , findFile, findFileWithExtension, matchFileGlob , withTempDirectory, defaultPackageDesc , die, warn, notice, info, setupMessage ) import Distribution.Simple.Setup ( Flag(..), SDistFlags(..) , fromFlag, flagToMaybe) import Distribution.Simple.PreProcess ( PPSuffixHandler, ppSuffixes , preprocessComponent ) import Distribution.Simple.LocalBuildInfo ( LocalBuildInfo(..), withAllComponentsInBuildOrder ) import Distribution.Simple.BuildPaths ( autogenModuleName ) import Distribution.Simple.Program ( defaultProgramConfiguration, requireProgram, runProgram, programProperties, tarProgram ) import Distribution.Text ( display ) import Control.Monad(when, unless, forM) import Data.Char (toLower) import Data.List (partition, isPrefixOf) import qualified Data.Map as Map import Data.Maybe (isNothing, catMaybes) import Data.Time (UTCTime, getCurrentTime, toGregorian, utctDay) import System.Directory ( doesFileExist ) import System.IO (IOMode(WriteMode), hPutStrLn, withFile) import Distribution.Verbosity (Verbosity) import System.FilePath ( (), (<.>), dropExtension, isAbsolute ) -- |Create a source distribution. sdist :: PackageDescription -- ^information from the tarball -> Maybe LocalBuildInfo -- ^Information from configure -> SDistFlags -- ^verbosity & snapshot -> (FilePath -> FilePath) -- ^build prefix (temp dir) -> [PPSuffixHandler] -- ^ extra preprocessors (includes suffixes) -> IO () sdist pkg mb_lbi flags mkTmpDir pps = -- When given --list-sources, just output the list of sources to a file. case (sDistListSources flags) of Flag path -> withFile path WriteMode $ \outHandle -> do (ordinary, maybeExecutable) <- listPackageSources verbosity pkg pps mapM_ (hPutStrLn outHandle) ordinary mapM_ (hPutStrLn outHandle) maybeExecutable notice verbosity $ "List of package sources written to file '" ++ path ++ "'" NoFlag -> do -- do some QA printPackageProblems verbosity pkg when (isNothing mb_lbi) $ warn verbosity "Cannot run preprocessors. Run 'configure' command first." date <- getCurrentTime let pkg' | snapshot = snapshotPackage date pkg | otherwise = pkg case flagToMaybe (sDistDirectory flags) of Just targetDir -> do generateSourceDir targetDir pkg' info verbosity $ "Source directory created: " ++ targetDir Nothing -> do createDirectoryIfMissingVerbose verbosity True tmpTargetDir withTempDirectory verbosity tmpTargetDir "sdist." $ \tmpDir -> do let targetDir = tmpDir tarBallName pkg' generateSourceDir targetDir pkg' targzFile <- createArchive verbosity pkg' mb_lbi tmpDir targetPref notice verbosity $ "Source tarball created: " ++ targzFile where generateSourceDir targetDir pkg' = do setupMessage verbosity "Building source dist for" (packageId pkg') prepareTree verbosity pkg' mb_lbi targetDir pps when snapshot $ overwriteSnapshotPackageDesc verbosity pkg' targetDir verbosity = fromFlag (sDistVerbosity flags) snapshot = fromFlag (sDistSnapshot flags) distPref = fromFlag $ sDistDistPref flags targetPref = distPref tmpTargetDir = mkTmpDir distPref -- | List all source files of a package. Returns a tuple of lists: first -- component is a list of ordinary files, second one is a list of those files -- that may be executable. listPackageSources :: Verbosity -- ^ verbosity -> PackageDescription -- ^ info from the cabal file -> [PPSuffixHandler] -- ^ extra preprocessors (include -- suffixes) -> IO ([FilePath], [FilePath]) listPackageSources verbosity pkg_descr0 pps = do -- Call helpers that actually do all work. ordinary <- listPackageSourcesOrdinary verbosity pkg_descr pps maybeExecutable <- listPackageSourcesMaybeExecutable pkg_descr return (ordinary, maybeExecutable) where pkg_descr = filterAutogenModule pkg_descr0 -- | List those source files that may be executable (e.g. the configure script). listPackageSourcesMaybeExecutable :: PackageDescription -> IO [FilePath] listPackageSourcesMaybeExecutable pkg_descr = -- Extra source files. fmap concat . forM (extraSrcFiles pkg_descr) $ \fpath -> matchFileGlob fpath -- | List those source files that should be copied with ordinary permissions. listPackageSourcesOrdinary :: Verbosity -> PackageDescription -> [PPSuffixHandler] -> IO [FilePath] listPackageSourcesOrdinary verbosity pkg_descr pps = fmap concat . sequence $ [ -- Library sources. withLib $ \Library { exposedModules = modules, libBuildInfo = libBi } -> allSourcesBuildInfo libBi pps modules -- Executables sources. , fmap concat . withExe $ \Executable { modulePath = mainPath, buildInfo = exeBi } -> do biSrcs <- allSourcesBuildInfo exeBi pps [] mainSrc <- findMainExeFile exeBi pps mainPath return (mainSrc:biSrcs) -- Test suites sources. , fmap concat . withTest $ \t -> do let bi = testBuildInfo t case testInterface t of TestSuiteExeV10 _ mainPath -> do biSrcs <- allSourcesBuildInfo bi pps [] srcMainFile <- do ppFile <- findFileWithExtension (ppSuffixes pps) (hsSourceDirs bi) (dropExtension mainPath) case ppFile of Nothing -> findFile (hsSourceDirs bi) mainPath Just pp -> return pp return (srcMainFile:biSrcs) TestSuiteLibV09 _ m -> allSourcesBuildInfo bi pps [m] TestSuiteUnsupported tp -> die $ "Unsupported test suite type: " ++ show tp -- Benchmarks sources. , fmap concat . withBenchmark $ \bm -> do let bi = benchmarkBuildInfo bm case benchmarkInterface bm of BenchmarkExeV10 _ mainPath -> do biSrcs <- allSourcesBuildInfo bi pps [] srcMainFile <- do ppFile <- findFileWithExtension (ppSuffixes pps) (hsSourceDirs bi) (dropExtension mainPath) case ppFile of Nothing -> findFile (hsSourceDirs bi) mainPath Just pp -> return pp return (srcMainFile:biSrcs) BenchmarkUnsupported tp -> die $ "Unsupported benchmark type: " ++ show tp -- Data files. , fmap concat . forM (dataFiles pkg_descr) $ \filename -> matchFileGlob (dataDir pkg_descr filename) -- Extra doc files. , fmap concat . forM (extraDocFiles pkg_descr) $ \ filename -> matchFileGlob filename -- License file(s). , return (licenseFiles pkg_descr) -- Install-include files. , withLib $ \ l -> do let lbi = libBuildInfo l relincdirs = "." : filter (not.isAbsolute) (includeDirs lbi) mapM (fmap snd . findIncludeFile relincdirs) (installIncludes lbi) -- Setup script, if it exists. , fmap (maybe [] (\f -> [f])) $ findSetupFile "" -- The .cabal file itself. , fmap (\d -> [d]) (defaultPackageDesc verbosity) ] where -- We have to deal with all libs and executables, so we have local -- versions of these functions that ignore the 'buildable' attribute: withLib action = maybe (return []) action (library pkg_descr) withExe action = mapM action (executables pkg_descr) withTest action = mapM action (testSuites pkg_descr) withBenchmark action = mapM action (benchmarks pkg_descr) -- |Prepare a directory tree of source files. prepareTree :: Verbosity -- ^verbosity -> PackageDescription -- ^info from the cabal file -> Maybe LocalBuildInfo -> FilePath -- ^source tree to populate -> [PPSuffixHandler] -- ^extra preprocessors (includes suffixes) -> IO () prepareTree verbosity pkg_descr0 mb_lbi targetDir pps = do -- If the package was configured then we can run platform-independent -- pre-processors and include those generated files. case mb_lbi of Just lbi | not (null pps) -> do let lbi' = lbi{ buildDir = targetDir buildDir lbi } withAllComponentsInBuildOrder pkg_descr lbi' $ \c _ -> preprocessComponent pkg_descr c lbi' True verbosity pps _ -> return () (ordinary, mExecutable) <- listPackageSources verbosity pkg_descr0 pps installOrdinaryFiles verbosity targetDir (zip (repeat []) ordinary) installMaybeExecutableFiles verbosity targetDir (zip (repeat []) mExecutable) maybeCreateDefaultSetupScript targetDir where pkg_descr = filterAutogenModule pkg_descr0 -- | Find the setup script file, if it exists. findSetupFile :: FilePath -> IO (Maybe FilePath) findSetupFile targetDir = do hsExists <- doesFileExist setupHs lhsExists <- doesFileExist setupLhs if hsExists then return (Just setupHs) else if lhsExists then return (Just setupLhs) else return Nothing where setupHs = targetDir "Setup.hs" setupLhs = targetDir "Setup.lhs" -- | Create a default setup script in the target directory, if it doesn't exist. maybeCreateDefaultSetupScript :: FilePath -> IO () maybeCreateDefaultSetupScript targetDir = do mSetupFile <- findSetupFile targetDir case mSetupFile of Just _setupFile -> return () Nothing -> do writeUTF8File (targetDir "Setup.hs") $ unlines [ "import Distribution.Simple", "main = defaultMain"] -- | Find the main executable file. findMainExeFile :: BuildInfo -> [PPSuffixHandler] -> FilePath -> IO FilePath findMainExeFile exeBi pps mainPath = do ppFile <- findFileWithExtension (ppSuffixes pps) (hsSourceDirs exeBi) (dropExtension mainPath) case ppFile of Nothing -> findFile (hsSourceDirs exeBi) mainPath Just pp -> return pp -- | Given a list of include paths, try to find the include file named -- @f@. Return the name of the file and the full path, or exit with error if -- there's no such file. findIncludeFile :: [FilePath] -> String -> IO (String, FilePath) findIncludeFile [] f = die ("can't find include file " ++ f) findIncludeFile (d:ds) f = do let path = (d f) b <- doesFileExist path if b then return (f,path) else findIncludeFile ds f -- | Remove the auto-generated module ('Paths_*') from 'exposed-modules' and -- 'other-modules'. filterAutogenModule :: PackageDescription -> PackageDescription filterAutogenModule pkg_descr0 = mapLib filterAutogenModuleLib $ mapAllBuildInfo filterAutogenModuleBI pkg_descr0 where mapLib f pkg = pkg { library = fmap f (library pkg) } filterAutogenModuleLib lib = lib { exposedModules = filter (/=autogenModule) (exposedModules lib) } filterAutogenModuleBI bi = bi { otherModules = filter (/=autogenModule) (otherModules bi) } autogenModule = autogenModuleName pkg_descr0 -- | Prepare a directory tree of source files for a snapshot version. -- It is expected that the appropriate snapshot version has already been set -- in the package description, eg using 'snapshotPackage' or 'snapshotVersion'. -- prepareSnapshotTree :: Verbosity -- ^verbosity -> PackageDescription -- ^info from the cabal file -> Maybe LocalBuildInfo -> FilePath -- ^source tree to populate -> [PPSuffixHandler] -- ^extra preprocessors (includes -- suffixes) -> IO () prepareSnapshotTree verbosity pkg mb_lbi targetDir pps = do prepareTree verbosity pkg mb_lbi targetDir pps overwriteSnapshotPackageDesc verbosity pkg targetDir overwriteSnapshotPackageDesc :: Verbosity -- ^verbosity -> PackageDescription -- ^info from the cabal file -> FilePath -- ^source tree -> IO () overwriteSnapshotPackageDesc verbosity pkg targetDir = do -- We could just writePackageDescription targetDescFile pkg_descr, -- but that would lose comments and formatting. descFile <- defaultPackageDesc verbosity withUTF8FileContents descFile $ writeUTF8File (targetDir descFile) . unlines . map (replaceVersion (packageVersion pkg)) . lines where replaceVersion :: Version -> String -> String replaceVersion version line | "version:" `isPrefixOf` map toLower line = "version: " ++ display version | otherwise = line -- | Modifies a 'PackageDescription' by appending a snapshot number -- corresponding to the given date. -- snapshotPackage :: UTCTime -> PackageDescription -> PackageDescription snapshotPackage date pkg = pkg { package = pkgid { pkgVersion = snapshotVersion date (pkgVersion pkgid) } } where pkgid = packageId pkg -- | Modifies a 'Version' by appending a snapshot number corresponding -- to the given date. -- snapshotVersion :: UTCTime -> Version -> Version snapshotVersion date version = version { versionBranch = versionBranch version ++ [dateToSnapshotNumber date] } -- | Given a date produce a corresponding integer representation. -- For example given a date @18/03/2008@ produce the number @20080318@. -- dateToSnapshotNumber :: UTCTime -> Int dateToSnapshotNumber date = case toGregorian (utctDay date) of (year, month, day) -> fromIntegral year * 10000 + month * 100 + day -- | Callback type for use by sdistWith. type CreateArchiveFun = Verbosity -- ^verbosity -> PackageDescription -- ^info from cabal file -> Maybe LocalBuildInfo -- ^info from configure -> FilePath -- ^source tree to archive -> FilePath -- ^name of archive to create -> IO FilePath -- | Create an archive from a tree of source files, and clean up the tree. createArchive :: CreateArchiveFun createArchive verbosity pkg_descr mb_lbi tmpDir targetPref = do let tarBallFilePath = targetPref tarBallName pkg_descr <.> "tar.gz" (tarProg, _) <- requireProgram verbosity tarProgram (maybe defaultProgramConfiguration withPrograms mb_lbi) let formatOptSupported = maybe False (== "YES") $ Map.lookup "Supports --format" (programProperties tarProg) runProgram verbosity tarProg $ -- Hmm: I could well be skating on thinner ice here by using the -C option -- (=> seems to be supported at least by GNU and *BSD tar) [The -- prev. solution used pipes and sub-command sequences to set up the paths -- correctly, which is problematic in a Windows setting.] ["-czf", tarBallFilePath, "-C", tmpDir] ++ (if formatOptSupported then ["--format", "ustar"] else []) ++ [tarBallName pkg_descr] return tarBallFilePath -- | Given a buildinfo, return the names of all source files. allSourcesBuildInfo :: BuildInfo -> [PPSuffixHandler] -- ^ Extra preprocessors -> [ModuleName] -- ^ Exposed modules -> IO [FilePath] allSourcesBuildInfo bi pps modules = do let searchDirs = hsSourceDirs bi sources <- sequence [ let file = ModuleName.toFilePath module_ in findFileWithExtension suffixes searchDirs file >>= maybe (notFound module_) return | module_ <- modules ++ otherModules bi ] bootFiles <- sequence [ let file = ModuleName.toFilePath module_ fileExts = ["hs-boot", "lhs-boot"] in findFileWithExtension fileExts (hsSourceDirs bi) file | module_ <- modules ++ otherModules bi ] return $ sources ++ catMaybes bootFiles ++ cSources bi ++ jsSources bi where suffixes = ppSuffixes pps ++ ["hs", "lhs"] notFound m = die $ "Error: Could not find module: " ++ display m ++ " with any suffix: " ++ show suffixes printPackageProblems :: Verbosity -> PackageDescription -> IO () printPackageProblems verbosity pkg_descr = do ioChecks <- checkPackageFiles pkg_descr "." let pureChecks = checkConfiguredPackage pkg_descr isDistError (PackageDistSuspicious _) = False isDistError _ = True (errors, warnings) = partition isDistError (pureChecks ++ ioChecks) unless (null errors) $ notice verbosity $ "Distribution quality errors:\n" ++ unlines (map explanation errors) unless (null warnings) $ notice verbosity $ "Distribution quality warnings:\n" ++ unlines (map explanation warnings) unless (null errors) $ notice verbosity "Note: the public hackage server would reject this package." ------------------------------------------------------------ -- | The name of the tarball without extension -- tarBallName :: PackageDescription -> String tarBallName = display . packageId mapAllBuildInfo :: (BuildInfo -> BuildInfo) -> (PackageDescription -> PackageDescription) mapAllBuildInfo f pkg = pkg { library = fmap mapLibBi (library pkg), executables = fmap mapExeBi (executables pkg), testSuites = fmap mapTestBi (testSuites pkg), benchmarks = fmap mapBenchBi (benchmarks pkg) } where mapLibBi lib = lib { libBuildInfo = f (libBuildInfo lib) } mapExeBi exe = exe { buildInfo = f (buildInfo exe) } mapTestBi t = t { testBuildInfo = f (testBuildInfo t) } mapBenchBi bm = bm { benchmarkBuildInfo = f (benchmarkBuildInfo bm) } Cabal-1.22.5.0/Distribution/Simple/Test.hs0000644000000000000000000001266712627136220016327 0ustar0000000000000000----------------------------------------------------------------------------- -- | -- Module : Distribution.Simple.Test -- Copyright : Thomas Tuegel 2010 -- License : BSD3 -- -- Maintainer : cabal-devel@haskell.org -- Portability : portable -- -- This is the entry point into testing a built package. It performs the -- \"@.\/setup test@\" action. It runs test suites designated in the package -- description and reports on the results. module Distribution.Simple.Test ( test ) where import qualified Distribution.PackageDescription as PD ( PackageDescription(..), BuildInfo(buildable) , TestSuite(..) , TestSuiteInterface(..), testType, hasTests ) import Distribution.Simple.Compiler ( compilerInfo ) import Distribution.Simple.Hpc ( markupPackage ) import Distribution.Simple.InstallDirs ( fromPathTemplate, initialPathTemplateEnv, substPathTemplate , PathTemplate ) import qualified Distribution.Simple.LocalBuildInfo as LBI ( LocalBuildInfo(..) ) import Distribution.Simple.Setup ( TestFlags(..), fromFlag, configCoverage ) import Distribution.Simple.UserHooks ( Args ) import qualified Distribution.Simple.Test.ExeV10 as ExeV10 import qualified Distribution.Simple.Test.LibV09 as LibV09 import Distribution.Simple.Test.Log import Distribution.Simple.Utils ( die, notice ) import Distribution.TestSuite ( Result(..) ) import Distribution.Text import Control.Monad ( when, unless, filterM ) import System.Directory ( createDirectoryIfMissing, doesFileExist, getDirectoryContents , removeFile ) import System.Exit ( ExitCode(..), exitFailure, exitWith ) import System.FilePath ( () ) -- |Perform the \"@.\/setup test@\" action. test :: Args -- ^positional command-line arguments -> PD.PackageDescription -- ^information from the .cabal file -> LBI.LocalBuildInfo -- ^information from the configure step -> TestFlags -- ^flags sent to test -> IO () test args pkg_descr lbi flags = do let verbosity = fromFlag $ testVerbosity flags machineTemplate = fromFlag $ testMachineLog flags distPref = fromFlag $ testDistPref flags testLogDir = distPref "test" testNames = args pkgTests = PD.testSuites pkg_descr enabledTests = [ t | t <- pkgTests , PD.testEnabled t , PD.buildable (PD.testBuildInfo t) ] doTest :: (PD.TestSuite, Maybe TestSuiteLog) -> IO TestSuiteLog doTest (suite, _) = case PD.testInterface suite of PD.TestSuiteExeV10 _ _ -> ExeV10.runTest pkg_descr lbi flags suite PD.TestSuiteLibV09 _ _ -> LibV09.runTest pkg_descr lbi flags suite _ -> return TestSuiteLog { testSuiteName = PD.testName suite , testLogs = TestLog { testName = PD.testName suite , testOptionsReturned = [] , testResult = Error $ "No support for running test suite type: " ++ show (disp $ PD.testType suite) } , logFile = "" } when (not $ PD.hasTests pkg_descr) $ do notice verbosity "Package has no test suites." exitWith ExitSuccess when (PD.hasTests pkg_descr && null enabledTests) $ die $ "No test suites enabled. Did you remember to configure with " ++ "\'--enable-tests\'?" testsToRun <- case testNames of [] -> return $ zip enabledTests $ repeat Nothing names -> flip mapM names $ \tName -> let testMap = zip enabledNames enabledTests enabledNames = map PD.testName enabledTests allNames = map PD.testName pkgTests in case lookup tName testMap of Just t -> return (t, Nothing) _ | tName `elem` allNames -> die $ "Package configured with test suite " ++ tName ++ " disabled." | otherwise -> die $ "no such test: " ++ tName createDirectoryIfMissing True testLogDir -- Delete ordinary files from test log directory. getDirectoryContents testLogDir >>= filterM doesFileExist . map (testLogDir ) >>= mapM_ removeFile let totalSuites = length testsToRun notice verbosity $ "Running " ++ show totalSuites ++ " test suites..." suites <- mapM doTest testsToRun let packageLog = (localPackageLog pkg_descr lbi) { testSuites = suites } packageLogFile = () testLogDir $ packageLogPath machineTemplate pkg_descr lbi allOk <- summarizePackage verbosity packageLog writeFile packageLogFile $ show packageLog let isCoverageEnabled = fromFlag $ configCoverage $ LBI.configFlags lbi when isCoverageEnabled $ markupPackage verbosity lbi distPref (display $ PD.package pkg_descr) $ map fst testsToRun unless allOk exitFailure packageLogPath :: PathTemplate -> PD.PackageDescription -> LBI.LocalBuildInfo -> FilePath packageLogPath template pkg_descr lbi = fromPathTemplate $ substPathTemplate env template where env = initialPathTemplateEnv (PD.package pkg_descr) (LBI.pkgKey lbi) (compilerInfo $ LBI.compiler lbi) (LBI.hostPlatform lbi) Cabal-1.22.5.0/Distribution/Simple/UHC.hs0000644000000000000000000002613112627136220016016 0ustar0000000000000000----------------------------------------------------------------------------- -- | -- Module : Distribution.Simple.UHC -- Copyright : Andres Loeh 2009 -- License : BSD3 -- -- Maintainer : cabal-devel@haskell.org -- Portability : portable -- -- This module contains most of the UHC-specific code for configuring, building -- and installing packages. -- -- Thanks to the authors of the other implementation-specific files, in -- particular to Isaac Jones, Duncan Coutts and Henning Thielemann, for -- inspiration on how to design this module. module Distribution.Simple.UHC ( configure, getInstalledPackages, buildLib, buildExe, installLib, registerPackage ) where import Control.Monad import Data.List import qualified Data.Map as M ( empty ) import Distribution.Compat.ReadP import Distribution.InstalledPackageInfo import Distribution.Package hiding (installedPackageId) import Distribution.PackageDescription import Distribution.Simple.BuildPaths import Distribution.Simple.Compiler as C import Distribution.Simple.LocalBuildInfo import Distribution.Simple.PackageIndex import Distribution.Simple.Program import Distribution.Simple.Utils import Distribution.Text import Distribution.Verbosity import Distribution.Version import Language.Haskell.Extension import System.Directory import System.FilePath import Distribution.System ( Platform ) -- ----------------------------------------------------------------------------- -- Configuring configure :: Verbosity -> Maybe FilePath -> Maybe FilePath -> ProgramConfiguration -> IO (Compiler, Maybe Platform, ProgramConfiguration) configure verbosity hcPath _hcPkgPath conf = do (_uhcProg, uhcVersion, conf') <- requireProgramVersion verbosity uhcProgram (orLaterVersion (Version [1,0,2] [])) (userMaybeSpecifyPath "uhc" hcPath conf) let comp = Compiler { compilerId = CompilerId UHC uhcVersion, compilerAbiTag = C.NoAbiTag, compilerCompat = [], compilerLanguages = uhcLanguages, compilerExtensions = uhcLanguageExtensions, compilerProperties = M.empty } compPlatform = Nothing return (comp, compPlatform, conf') uhcLanguages :: [(Language, C.Flag)] uhcLanguages = [(Haskell98, "")] -- | The flags for the supported extensions. uhcLanguageExtensions :: [(Extension, C.Flag)] uhcLanguageExtensions = let doFlag (f, (enable, disable)) = [(EnableExtension f, enable), (DisableExtension f, disable)] alwaysOn = ("", ""{- wrong -}) in concatMap doFlag [(CPP, ("--cpp", ""{- wrong -})), (PolymorphicComponents, alwaysOn), (ExistentialQuantification, alwaysOn), (ForeignFunctionInterface, alwaysOn), (UndecidableInstances, alwaysOn), (MultiParamTypeClasses, alwaysOn), (Rank2Types, alwaysOn), (PatternSignatures, alwaysOn), (EmptyDataDecls, alwaysOn), (ImplicitPrelude, ("", "--no-prelude"{- wrong -})), (TypeOperators, alwaysOn), (OverlappingInstances, alwaysOn), (FlexibleInstances, alwaysOn)] getInstalledPackages :: Verbosity -> Compiler -> PackageDBStack -> ProgramConfiguration -> IO InstalledPackageIndex getInstalledPackages verbosity comp packagedbs conf = do let compilerid = compilerId comp systemPkgDir <- rawSystemProgramStdoutConf verbosity uhcProgram conf ["--meta-pkgdir-system"] userPkgDir <- getUserPackageDir let pkgDirs = nub (concatMap (packageDbPaths userPkgDir systemPkgDir) packagedbs) -- putStrLn $ "pkgdirs: " ++ show pkgDirs -- call to "lines" necessary, because pkgdir contains an extra newline at the end pkgs <- liftM (map addBuiltinVersions . concat) . mapM (\ d -> getDirectoryContents d >>= filterM (isPkgDir (display compilerid) d)) . concatMap lines $ pkgDirs -- putStrLn $ "pkgs: " ++ show pkgs let iPkgs = map mkInstalledPackageInfo $ concatMap parsePackage $ pkgs -- putStrLn $ "installed pkgs: " ++ show iPkgs return (fromList iPkgs) getUserPackageDir :: IO FilePath getUserPackageDir = do homeDir <- getHomeDirectory return $ homeDir ".cabal" "lib" -- TODO: determine in some other way packageDbPaths :: FilePath -> FilePath -> PackageDB -> [FilePath] packageDbPaths user system db = case db of GlobalPackageDB -> [ system ] UserPackageDB -> [ user ] SpecificPackageDB path -> [ path ] -- | Hack to add version numbers to UHC-built-in packages. This should sooner or -- later be fixed on the UHC side. addBuiltinVersions :: String -> String {- addBuiltinVersions "uhcbase" = "uhcbase-1.0" addBuiltinVersions "base" = "base-3.0" addBuiltinVersions "array" = "array-0.2" -} addBuiltinVersions xs = xs -- | Name of the installed package config file. installedPkgConfig :: String installedPkgConfig = "installed-pkg-config" -- | Check if a certain dir contains a valid package. Currently, we are -- looking only for the presence of an installed package configuration. -- TODO: Actually make use of the information provided in the file. isPkgDir :: String -> String -> String -> IO Bool isPkgDir _ _ ('.' : _) = return False -- ignore files starting with a . isPkgDir c dir xs = do let candidate = dir uhcPackageDir xs c -- putStrLn $ "trying: " ++ candidate doesFileExist (candidate installedPkgConfig) parsePackage :: String -> [PackageId] parsePackage x = map fst (filter (\ (_,y) -> null y) (readP_to_S parse x)) -- | Create a trivial package info from a directory name. mkInstalledPackageInfo :: PackageId -> InstalledPackageInfo mkInstalledPackageInfo p = emptyInstalledPackageInfo { installedPackageId = InstalledPackageId (display p), sourcePackageId = p } -- ----------------------------------------------------------------------------- -- Building buildLib :: Verbosity -> PackageDescription -> LocalBuildInfo -> Library -> ComponentLocalBuildInfo -> IO () buildLib verbosity pkg_descr lbi lib clbi = do systemPkgDir <- rawSystemProgramStdoutConf verbosity uhcProgram (withPrograms lbi) ["--meta-pkgdir-system"] userPkgDir <- getUserPackageDir let runUhcProg = rawSystemProgramConf verbosity uhcProgram (withPrograms lbi) let uhcArgs = -- set package name ["--pkg-build=" ++ display (packageId pkg_descr)] -- common flags lib/exe ++ constructUHCCmdLine userPkgDir systemPkgDir lbi (libBuildInfo lib) clbi (buildDir lbi) verbosity -- source files -- suboptimal: UHC does not understand module names, so -- we replace periods by path separators ++ map (map (\ c -> if c == '.' then pathSeparator else c)) (map display (libModules lib)) runUhcProg uhcArgs return () buildExe :: Verbosity -> PackageDescription -> LocalBuildInfo -> Executable -> ComponentLocalBuildInfo -> IO () buildExe verbosity _pkg_descr lbi exe clbi = do systemPkgDir <- rawSystemProgramStdoutConf verbosity uhcProgram (withPrograms lbi) ["--meta-pkgdir-system"] userPkgDir <- getUserPackageDir let runUhcProg = rawSystemProgramConf verbosity uhcProgram (withPrograms lbi) let uhcArgs = -- common flags lib/exe constructUHCCmdLine userPkgDir systemPkgDir lbi (buildInfo exe) clbi (buildDir lbi) verbosity -- output file ++ ["--output", buildDir lbi exeName exe] -- main source module ++ [modulePath exe] runUhcProg uhcArgs constructUHCCmdLine :: FilePath -> FilePath -> LocalBuildInfo -> BuildInfo -> ComponentLocalBuildInfo -> FilePath -> Verbosity -> [String] constructUHCCmdLine user system lbi bi clbi odir verbosity = -- verbosity (if verbosity >= deafening then ["-v4"] else if verbosity >= normal then [] else ["-v0"]) ++ hcOptions UHC bi -- flags for language extensions ++ languageToFlags (compiler lbi) (defaultLanguage bi) ++ extensionsToFlags (compiler lbi) (usedExtensions bi) -- packages ++ ["--hide-all-packages"] ++ uhcPackageDbOptions user system (withPackageDB lbi) ++ ["--package=uhcbase"] ++ ["--package=" ++ display (pkgName pkgid) | (_, pkgid) <- componentPackageDeps clbi ] -- search paths ++ ["-i" ++ odir] ++ ["-i" ++ l | l <- nub (hsSourceDirs bi)] ++ ["-i" ++ autogenModulesDir lbi] -- cpp options ++ ["--optP=" ++ opt | opt <- cppOptions bi] -- output path ++ ["--odir=" ++ odir] -- optimization ++ (case withOptimization lbi of NoOptimisation -> ["-O0"] NormalOptimisation -> ["-O1"] MaximumOptimisation -> ["-O2"]) uhcPackageDbOptions :: FilePath -> FilePath -> PackageDBStack -> [String] uhcPackageDbOptions user system db = map (\ x -> "--pkg-searchpath=" ++ x) (concatMap (packageDbPaths user system) db) -- ----------------------------------------------------------------------------- -- Installation installLib :: Verbosity -> LocalBuildInfo -> FilePath -> FilePath -> FilePath -> PackageDescription -> Library -> IO () installLib verbosity _lbi targetDir _dynlibTargetDir builtDir pkg _library = do -- putStrLn $ "dest: " ++ targetDir -- putStrLn $ "built: " ++ builtDir installDirectoryContents verbosity (builtDir display (packageId pkg)) targetDir -- currently hard-coded UHC code generator and variant to use uhcTarget, uhcTargetVariant :: String uhcTarget = "bc" uhcTargetVariant = "plain" -- root directory for a package in UHC uhcPackageDir :: String -> String -> FilePath uhcPackageSubDir :: String -> FilePath uhcPackageDir pkgid compilerid = pkgid uhcPackageSubDir compilerid uhcPackageSubDir compilerid = compilerid uhcTarget uhcTargetVariant -- ----------------------------------------------------------------------------- -- Registering registerPackage :: Verbosity -> InstalledPackageInfo -> PackageDescription -> LocalBuildInfo -> Bool -> PackageDBStack -> IO () registerPackage verbosity installedPkgInfo pkg lbi inplace _packageDbs = do let installDirs = absoluteInstallDirs pkg lbi NoCopyDest pkgdir | inplace = buildDir lbi uhcPackageDir (display pkgid) (display compilerid) | otherwise = libdir installDirs uhcPackageSubDir (display compilerid) createDirectoryIfMissingVerbose verbosity True pkgdir writeUTF8File (pkgdir installedPkgConfig) (showInstalledPackageInfo installedPkgInfo) where pkgid = packageId pkg compilerid = compilerId (compiler lbi) Cabal-1.22.5.0/Distribution/Simple/UserHooks.hs0000644000000000000000000002347512627136220017331 0ustar0000000000000000----------------------------------------------------------------------------- -- | -- Module : Distribution.Simple.UserHooks -- Copyright : Isaac Jones 2003-2005 -- License : BSD3 -- -- Maintainer : cabal-devel@haskell.org -- Portability : portable -- -- This defines the API that @Setup.hs@ scripts can use to customise the way -- the build works. This module just defines the 'UserHooks' type. The -- predefined sets of hooks that implement the @Simple@, @Make@ and @Configure@ -- build systems are defined in "Distribution.Simple". The 'UserHooks' is a big -- record of functions. There are 3 for each action, a pre, post and the action -- itself. There are few other miscellaneous hooks, ones to extend the set of -- programs and preprocessors and one to override the function used to read the -- @.cabal@ file. -- -- This hooks type is widely agreed to not be the right solution. Partly this -- is because changes to it usually break custom @Setup.hs@ files and yet many -- internal code changes do require changes to the hooks. For example we cannot -- pass any extra parameters to most of the functions that implement the -- various phases because it would involve changing the types of the -- corresponding hook. At some point it will have to be replaced. module Distribution.Simple.UserHooks ( UserHooks(..), Args, emptyUserHooks, ) where import Distribution.PackageDescription (PackageDescription, GenericPackageDescription, HookedBuildInfo, emptyHookedBuildInfo) import Distribution.Simple.Program (Program) import Distribution.Simple.Command (noExtraFlags) import Distribution.Simple.PreProcess (PPSuffixHandler) import Distribution.Simple.Setup (ConfigFlags, BuildFlags, ReplFlags, CleanFlags, CopyFlags, InstallFlags, SDistFlags, RegisterFlags, HscolourFlags, HaddockFlags, TestFlags, BenchmarkFlags) import Distribution.Simple.LocalBuildInfo (LocalBuildInfo) type Args = [String] -- | Hooks allow authors to add specific functionality before and after a -- command is run, and also to specify additional preprocessors. -- -- * WARNING: The hooks interface is under rather constant flux as we try to -- understand users needs. Setup files that depend on this interface may -- break in future releases. data UserHooks = UserHooks { -- | Used for @.\/setup test@ runTests :: Args -> Bool -> PackageDescription -> LocalBuildInfo -> IO (), -- | Read the description file readDesc :: IO (Maybe GenericPackageDescription), -- | Custom preprocessors in addition to and overriding 'knownSuffixHandlers'. hookedPreProcessors :: [ PPSuffixHandler ], -- | These programs are detected at configure time. Arguments for them are -- added to the configure command. hookedPrograms :: [Program], -- |Hook to run before configure command preConf :: Args -> ConfigFlags -> IO HookedBuildInfo, -- |Over-ride this hook to get different behavior during configure. confHook :: (GenericPackageDescription, HookedBuildInfo) -> ConfigFlags -> IO LocalBuildInfo, -- |Hook to run after configure command postConf :: Args -> ConfigFlags -> PackageDescription -> LocalBuildInfo -> IO (), -- |Hook to run before build command. Second arg indicates verbosity level. preBuild :: Args -> BuildFlags -> IO HookedBuildInfo, -- |Over-ride this hook to get different behavior during build. buildHook :: PackageDescription -> LocalBuildInfo -> UserHooks -> BuildFlags -> IO (), -- |Hook to run after build command. Second arg indicates verbosity level. postBuild :: Args -> BuildFlags -> PackageDescription -> LocalBuildInfo -> IO (), -- |Hook to run before repl command. Second arg indicates verbosity level. preRepl :: Args -> ReplFlags -> IO HookedBuildInfo, -- |Over-ride this hook to get different behavior during interpretation. replHook :: PackageDescription -> LocalBuildInfo -> UserHooks -> ReplFlags -> [String] -> IO (), -- |Hook to run after repl command. Second arg indicates verbosity level. postRepl :: Args -> ReplFlags -> PackageDescription -> LocalBuildInfo -> IO (), -- |Hook to run before clean command. Second arg indicates verbosity level. preClean :: Args -> CleanFlags -> IO HookedBuildInfo, -- |Over-ride this hook to get different behavior during clean. cleanHook :: PackageDescription -> () -> UserHooks -> CleanFlags -> IO (), -- |Hook to run after clean command. Second arg indicates verbosity level. postClean :: Args -> CleanFlags -> PackageDescription -> () -> IO (), -- |Hook to run before copy command preCopy :: Args -> CopyFlags -> IO HookedBuildInfo, -- |Over-ride this hook to get different behavior during copy. copyHook :: PackageDescription -> LocalBuildInfo -> UserHooks -> CopyFlags -> IO (), -- |Hook to run after copy command postCopy :: Args -> CopyFlags -> PackageDescription -> LocalBuildInfo -> IO (), -- |Hook to run before install command preInst :: Args -> InstallFlags -> IO HookedBuildInfo, -- |Over-ride this hook to get different behavior during install. instHook :: PackageDescription -> LocalBuildInfo -> UserHooks -> InstallFlags -> IO (), -- |Hook to run after install command. postInst should be run -- on the target, not on the build machine. postInst :: Args -> InstallFlags -> PackageDescription -> LocalBuildInfo -> IO (), -- |Hook to run before sdist command. Second arg indicates verbosity level. preSDist :: Args -> SDistFlags -> IO HookedBuildInfo, -- |Over-ride this hook to get different behavior during sdist. sDistHook :: PackageDescription -> Maybe LocalBuildInfo -> UserHooks -> SDistFlags -> IO (), -- |Hook to run after sdist command. Second arg indicates verbosity level. postSDist :: Args -> SDistFlags -> PackageDescription -> Maybe LocalBuildInfo -> IO (), -- |Hook to run before register command preReg :: Args -> RegisterFlags -> IO HookedBuildInfo, -- |Over-ride this hook to get different behavior during registration. regHook :: PackageDescription -> LocalBuildInfo -> UserHooks -> RegisterFlags -> IO (), -- |Hook to run after register command postReg :: Args -> RegisterFlags -> PackageDescription -> LocalBuildInfo -> IO (), -- |Hook to run before unregister command preUnreg :: Args -> RegisterFlags -> IO HookedBuildInfo, -- |Over-ride this hook to get different behavior during unregistration. unregHook :: PackageDescription -> LocalBuildInfo -> UserHooks -> RegisterFlags -> IO (), -- |Hook to run after unregister command postUnreg :: Args -> RegisterFlags -> PackageDescription -> LocalBuildInfo -> IO (), -- |Hook to run before hscolour command. Second arg indicates verbosity level. preHscolour :: Args -> HscolourFlags -> IO HookedBuildInfo, -- |Over-ride this hook to get different behavior during hscolour. hscolourHook :: PackageDescription -> LocalBuildInfo -> UserHooks -> HscolourFlags -> IO (), -- |Hook to run after hscolour command. Second arg indicates verbosity level. postHscolour :: Args -> HscolourFlags -> PackageDescription -> LocalBuildInfo -> IO (), -- |Hook to run before haddock command. Second arg indicates verbosity level. preHaddock :: Args -> HaddockFlags -> IO HookedBuildInfo, -- |Over-ride this hook to get different behavior during haddock. haddockHook :: PackageDescription -> LocalBuildInfo -> UserHooks -> HaddockFlags -> IO (), -- |Hook to run after haddock command. Second arg indicates verbosity level. postHaddock :: Args -> HaddockFlags -> PackageDescription -> LocalBuildInfo -> IO (), -- |Hook to run before test command. preTest :: Args -> TestFlags -> IO HookedBuildInfo, -- |Over-ride this hook to get different behavior during test. testHook :: Args -> PackageDescription -> LocalBuildInfo -> UserHooks -> TestFlags -> IO (), -- |Hook to run after test command. postTest :: Args -> TestFlags -> PackageDescription -> LocalBuildInfo -> IO (), -- |Hook to run before bench command. preBench :: Args -> BenchmarkFlags -> IO HookedBuildInfo, -- |Over-ride this hook to get different behavior during bench. benchHook :: Args -> PackageDescription -> LocalBuildInfo -> UserHooks -> BenchmarkFlags -> IO (), -- |Hook to run after bench command. postBench :: Args -> BenchmarkFlags -> PackageDescription -> LocalBuildInfo -> IO () } {-# DEPRECATED runTests "Please use the new testing interface instead!" #-} -- |Empty 'UserHooks' which do nothing. emptyUserHooks :: UserHooks emptyUserHooks = UserHooks { runTests = ru, readDesc = return Nothing, hookedPreProcessors = [], hookedPrograms = [], preConf = rn, confHook = (\_ _ -> return (error "No local build info generated during configure. Over-ride empty configure hook.")), postConf = ru, preBuild = rn', buildHook = ru, postBuild = ru, preRepl = \_ _ -> return emptyHookedBuildInfo, replHook = \_ _ _ _ _ -> return (), postRepl = ru, preClean = rn, cleanHook = ru, postClean = ru, preCopy = rn, copyHook = ru, postCopy = ru, preInst = rn, instHook = ru, postInst = ru, preSDist = rn, sDistHook = ru, postSDist = ru, preReg = rn, regHook = ru, postReg = ru, preUnreg = rn, unregHook = ru, postUnreg = ru, preHscolour = rn, hscolourHook = ru, postHscolour = ru, preHaddock = rn, haddockHook = ru, postHaddock = ru, preTest = rn', testHook = \_ -> ru, postTest = ru, preBench = rn', benchHook = \_ -> ru, postBench = ru } where rn args _ = noExtraFlags args >> return emptyHookedBuildInfo rn' _ _ = return emptyHookedBuildInfo ru _ _ _ _ = return () Cabal-1.22.5.0/Distribution/Simple/Utils.hs0000644000000000000000000014352612627136220016507 0ustar0000000000000000{-# LANGUAGE CPP, ForeignFunctionInterface #-} ----------------------------------------------------------------------------- -- | -- Module : Distribution.Simple.Utils -- Copyright : Isaac Jones, Simon Marlow 2003-2004 -- License : BSD3 -- portions Copyright (c) 2007, Galois Inc. -- -- Maintainer : cabal-devel@haskell.org -- Portability : portable -- -- A large and somewhat miscellaneous collection of utility functions used -- throughout the rest of the Cabal lib and in other tools that use the Cabal -- lib like @cabal-install@. It has a very simple set of logging actions. It -- has low level functions for running programs, a bunch of wrappers for -- various directory and file functions that do extra logging. module Distribution.Simple.Utils ( cabalVersion, -- * logging and errors die, dieWithLocation, topHandler, topHandlerWith, warn, notice, setupMessage, info, debug, debugNoWrap, chattyTry, printRawCommandAndArgs, printRawCommandAndArgsAndEnv, -- * running programs rawSystemExit, rawSystemExitCode, rawSystemExitWithEnv, rawSystemStdout, rawSystemStdInOut, rawSystemIOWithEnv, maybeExit, xargs, findProgramLocation, findProgramVersion, -- * copying files smartCopySources, createDirectoryIfMissingVerbose, copyFileVerbose, copyDirectoryRecursiveVerbose, copyFiles, copyFileTo, -- * installing files installOrdinaryFile, installExecutableFile, installMaybeExecutableFile, installOrdinaryFiles, installExecutableFiles, installMaybeExecutableFiles, installDirectoryContents, copyDirectoryRecursive, -- * File permissions doesExecutableExist, setFileOrdinary, setFileExecutable, -- * file names currentDir, shortRelativePath, -- * finding files findFile, findFirstFile, findFileWithExtension, findFileWithExtension', findModuleFile, findModuleFiles, getDirectoryContentsRecursive, -- * environment variables isInSearchPath, addLibraryPath, -- * simple file globbing matchFileGlob, matchDirFileGlob, parseFileGlob, FileGlob(..), -- * modification time moreRecentFile, existsAndIsMoreRecentThan, -- * temp files and dirs TempFileOptions(..), defaultTempFileOptions, withTempFile, withTempFileEx, withTempDirectory, withTempDirectoryEx, -- * .cabal and .buildinfo files defaultPackageDesc, findPackageDesc, tryFindPackageDesc, defaultHookedPackageDesc, findHookedPackageDesc, -- * reading and writing files safely withFileContents, writeFileAtomic, rewriteFile, -- * Unicode fromUTF8, toUTF8, readUTF8File, withUTF8FileContents, writeUTF8File, normaliseLineEndings, -- * generic utils dropWhileEndLE, takeWhileEndLE, equating, comparing, isInfixOf, intercalate, lowercase, listUnion, listUnionRight, ordNub, ordNubRight, wrapText, wrapLine, ) where import Control.Monad ( join, when, unless, filterM ) import Control.Concurrent.MVar ( newEmptyMVar, putMVar, takeMVar ) import Data.List ( nub, unfoldr, isPrefixOf, tails, intercalate ) import Data.Char as Char ( isDigit, toLower, chr, ord ) import Data.Bits ( Bits((.|.), (.&.), shiftL, shiftR) ) import qualified Data.ByteString.Lazy as BS import qualified Data.ByteString.Lazy.Char8 as BS.Char8 import qualified Data.Set as Set import System.Directory ( Permissions(executable), getDirectoryContents, getPermissions , doesDirectoryExist, doesFileExist, removeFile, findExecutable , getModificationTime ) import System.Environment ( getProgName ) import System.Exit ( exitWith, ExitCode(..) ) import System.FilePath ( normalise, (), (<.>) , getSearchPath, joinPath, takeDirectory, splitFileName , splitExtension, splitExtensions, splitDirectories , searchPathSeparator ) import System.Directory ( createDirectory, renameFile, removeDirectoryRecursive ) import System.IO ( Handle, openFile, openBinaryFile, openBinaryTempFileWithDefaultPermissions , IOMode(ReadMode), hSetBinaryMode , hGetContents, stderr, stdout, hPutStr, hFlush, hClose ) import System.IO.Error as IO.Error ( isDoesNotExistError, isAlreadyExistsError , ioeSetFileName, ioeGetFileName, ioeGetErrorString ) import System.IO.Error ( ioeSetLocation, ioeGetLocation ) import System.IO.Unsafe ( unsafeInterleaveIO ) import qualified Control.Exception as Exception import Distribution.Text ( display, simpleParse ) import Distribution.Package ( PackageIdentifier ) import Distribution.ModuleName (ModuleName) import qualified Distribution.ModuleName as ModuleName import Distribution.System ( OS (..) ) import Distribution.Version (Version(..)) import Control.Exception (IOException, evaluate, throwIO) import Control.Concurrent (forkIO) import qualified System.Process as Process ( CreateProcess(..), StdStream(..), proc) import System.Process ( createProcess, rawSystem, runInteractiveProcess , showCommandForUser, waitForProcess) import Distribution.Compat.CopyFile ( copyFile, copyOrdinaryFile, copyExecutableFile , setFileOrdinary, setFileExecutable, setDirOrdinary ) import Distribution.Compat.TempFile ( openTempFile, createTempDirectory ) import Distribution.Compat.Exception ( tryIO, catchIO, catchExit ) import Distribution.Verbosity #ifdef VERSION_base import qualified Paths_Cabal (version) #endif -- We only get our own version number when we're building with ourselves cabalVersion :: Version #if defined(VERSION_base) cabalVersion = Paths_Cabal.version #elif defined(CABAL_VERSION) cabalVersion = Version [CABAL_VERSION] [] #else cabalVersion = Version [1,9999] [] --used when bootstrapping #endif -- ---------------------------------------------------------------------------- -- Exception and logging utils dieWithLocation :: FilePath -> Maybe Int -> String -> IO a dieWithLocation filename lineno msg = ioError . setLocation lineno . flip ioeSetFileName (normalise filename) $ userError msg where setLocation Nothing err = err setLocation (Just n) err = ioeSetLocation err (show n) die :: String -> IO a die msg = ioError (userError msg) topHandlerWith :: (Exception.IOException -> IO a) -> IO a -> IO a topHandlerWith cont prog = catchIO prog handle where handle ioe = do hFlush stdout pname <- getProgName hPutStr stderr (mesage pname) cont ioe where mesage pname = wrapText (pname ++ ": " ++ file ++ detail) file = case ioeGetFileName ioe of Nothing -> "" Just path -> path ++ location ++ ": " location = case ioeGetLocation ioe of l@(n:_) | Char.isDigit n -> ':' : l _ -> "" detail = ioeGetErrorString ioe topHandler :: IO a -> IO a topHandler prog = topHandlerWith (const $ exitWith (ExitFailure 1)) prog -- | Non fatal conditions that may be indicative of an error or problem. -- -- We display these at the 'normal' verbosity level. -- warn :: Verbosity -> String -> IO () warn verbosity msg = when (verbosity >= normal) $ do hFlush stdout hPutStr stderr (wrapText ("Warning: " ++ msg)) -- | Useful status messages. -- -- We display these at the 'normal' verbosity level. -- -- This is for the ordinary helpful status messages that users see. Just -- enough information to know that things are working but not floods of detail. -- notice :: Verbosity -> String -> IO () notice verbosity msg = when (verbosity >= normal) $ putStr (wrapText msg) setupMessage :: Verbosity -> String -> PackageIdentifier -> IO () setupMessage verbosity msg pkgid = notice verbosity (msg ++ ' ': display pkgid ++ "...") -- | More detail on the operation of some action. -- -- We display these messages when the verbosity level is 'verbose' -- info :: Verbosity -> String -> IO () info verbosity msg = when (verbosity >= verbose) $ putStr (wrapText msg) -- | Detailed internal debugging information -- -- We display these messages when the verbosity level is 'deafening' -- debug :: Verbosity -> String -> IO () debug verbosity msg = when (verbosity >= deafening) $ do putStr (wrapText msg) hFlush stdout -- | A variant of 'debug' that doesn't perform the automatic line -- wrapping. Produces better output in some cases. debugNoWrap :: Verbosity -> String -> IO () debugNoWrap verbosity msg = when (verbosity >= deafening) $ do putStrLn msg hFlush stdout -- | Perform an IO action, catching any IO exceptions and printing an error -- if one occurs. chattyTry :: String -- ^ a description of the action we were attempting -> IO () -- ^ the action itself -> IO () chattyTry desc action = catchIO action $ \exception -> putStrLn $ "Error while " ++ desc ++ ": " ++ show exception -- ----------------------------------------------------------------------------- -- Helper functions -- | Wraps text to the default line width. Existing newlines are preserved. wrapText :: String -> String wrapText = unlines . map (intercalate "\n" . map unwords . wrapLine 79 . words) . lines -- | Wraps a list of words to a list of lines of words of a particular width. wrapLine :: Int -> [String] -> [[String]] wrapLine width = wrap 0 [] where wrap :: Int -> [String] -> [String] -> [[String]] wrap 0 [] (w:ws) | length w + 1 > width = wrap (length w) [w] ws wrap col line (w:ws) | col + length w + 1 > width = reverse line : wrap 0 [] (w:ws) wrap col line (w:ws) = let col' = col + length w + 1 in wrap col' (w:line) ws wrap _ [] [] = [] wrap _ line [] = [reverse line] -- ----------------------------------------------------------------------------- -- rawSystem variants maybeExit :: IO ExitCode -> IO () maybeExit cmd = do res <- cmd unless (res == ExitSuccess) $ exitWith res printRawCommandAndArgs :: Verbosity -> FilePath -> [String] -> IO () printRawCommandAndArgs verbosity path args = printRawCommandAndArgsAndEnv verbosity path args Nothing printRawCommandAndArgsAndEnv :: Verbosity -> FilePath -> [String] -> Maybe [(String, String)] -> IO () printRawCommandAndArgsAndEnv verbosity path args menv | verbosity >= deafening = do maybe (return ()) (putStrLn . ("Environment: " ++) . show) menv print (path, args) | verbosity >= verbose = putStrLn $ showCommandForUser path args | otherwise = return () -- Exit with the same exit code if the subcommand fails rawSystemExit :: Verbosity -> FilePath -> [String] -> IO () rawSystemExit verbosity path args = do printRawCommandAndArgs verbosity path args hFlush stdout exitcode <- rawSystem path args unless (exitcode == ExitSuccess) $ do debug verbosity $ path ++ " returned " ++ show exitcode exitWith exitcode rawSystemExitCode :: Verbosity -> FilePath -> [String] -> IO ExitCode rawSystemExitCode verbosity path args = do printRawCommandAndArgs verbosity path args hFlush stdout exitcode <- rawSystem path args unless (exitcode == ExitSuccess) $ do debug verbosity $ path ++ " returned " ++ show exitcode return exitcode rawSystemExitWithEnv :: Verbosity -> FilePath -> [String] -> [(String, String)] -> IO () rawSystemExitWithEnv verbosity path args env = do printRawCommandAndArgsAndEnv verbosity path args (Just env) hFlush stdout (_,_,_,ph) <- createProcess $ (Process.proc path args) { Process.env = (Just env) #ifdef MIN_VERSION_process #if MIN_VERSION_process(1,2,0) -- delegate_ctlc has been added in process 1.2, and we still want to be able to -- bootstrap GHC on systems not having that version , Process.delegate_ctlc = True #endif #endif } exitcode <- waitForProcess ph unless (exitcode == ExitSuccess) $ do debug verbosity $ path ++ " returned " ++ show exitcode exitWith exitcode -- Closes the passed in handles before returning. rawSystemIOWithEnv :: Verbosity -> FilePath -> [String] -> Maybe FilePath -- ^ New working dir or inherit -> Maybe [(String, String)] -- ^ New environment or inherit -> Maybe Handle -- ^ stdin -> Maybe Handle -- ^ stdout -> Maybe Handle -- ^ stderr -> IO ExitCode rawSystemIOWithEnv verbosity path args mcwd menv inp out err = do printRawCommandAndArgsAndEnv verbosity path args menv hFlush stdout (_,_,_,ph) <- createProcess $ (Process.proc path args) { Process.cwd = mcwd , Process.env = menv , Process.std_in = mbToStd inp , Process.std_out = mbToStd out , Process.std_err = mbToStd err #ifdef MIN_VERSION_process #if MIN_VERSION_process(1,2,0) -- delegate_ctlc has been added in process 1.2, and we still want to be able to -- bootstrap GHC on systems not having that version , Process.delegate_ctlc = True #endif #endif } exitcode <- waitForProcess ph unless (exitcode == ExitSuccess) $ do debug verbosity $ path ++ " returned " ++ show exitcode return exitcode where mbToStd :: Maybe Handle -> Process.StdStream mbToStd = maybe Process.Inherit Process.UseHandle -- | Run a command and return its output. -- -- The output is assumed to be text in the locale encoding. -- rawSystemStdout :: Verbosity -> FilePath -> [String] -> IO String rawSystemStdout verbosity path args = do (output, errors, exitCode) <- rawSystemStdInOut verbosity path args Nothing Nothing Nothing False when (exitCode /= ExitSuccess) $ die errors return output -- | Run a command and return its output, errors and exit status. Optionally -- also supply some input. Also provides control over whether the binary/text -- mode of the input and output. -- rawSystemStdInOut :: Verbosity -> FilePath -- ^ Program location -> [String] -- ^ Arguments -> Maybe FilePath -- ^ New working dir or inherit -> Maybe [(String, String)] -- ^ New environment or inherit -> Maybe (String, Bool) -- ^ input text and binary mode -> Bool -- ^ output in binary mode -> IO (String, String, ExitCode) -- ^ output, errors, exit rawSystemStdInOut verbosity path args mcwd menv input outputBinary = do printRawCommandAndArgs verbosity path args Exception.bracket (runInteractiveProcess path args mcwd menv) (\(inh,outh,errh,_) -> hClose inh >> hClose outh >> hClose errh) $ \(inh,outh,errh,pid) -> do -- output mode depends on what the caller wants hSetBinaryMode outh outputBinary -- but the errors are always assumed to be text (in the current locale) hSetBinaryMode errh False -- fork off a couple threads to pull on the stderr and stdout -- so if the process writes to stderr we do not block. err <- hGetContents errh out <- hGetContents outh mv <- newEmptyMVar let force str = (evaluate (length str) >> return ()) `Exception.finally` putMVar mv () --TODO: handle exceptions like text decoding. _ <- forkIO $ force out _ <- forkIO $ force err -- push all the input, if any case input of Nothing -> return () Just (inputStr, inputBinary) -> do -- input mode depends on what the caller wants hSetBinaryMode inh inputBinary hPutStr inh inputStr hClose inh --TODO: this probably fails if the process refuses to consume -- or if it closes stdin (eg if it exits) -- wait for both to finish, in either order takeMVar mv takeMVar mv -- wait for the program to terminate exitcode <- waitForProcess pid unless (exitcode == ExitSuccess) $ debug verbosity $ path ++ " returned " ++ show exitcode ++ if null err then "" else " with error message:\n" ++ err ++ case input of Nothing -> "" Just ("", _) -> "" Just (inp, _) -> "\nstdin input:\n" ++ inp return (out, err, exitcode) -- | Look for a program on the path. findProgramLocation :: Verbosity -> FilePath -> IO (Maybe FilePath) findProgramLocation verbosity prog = do debug verbosity $ "searching for " ++ prog ++ " in path." res <- findExecutable prog case res of Nothing -> debug verbosity ("Cannot find " ++ prog ++ " on the path") Just path -> debug verbosity ("found " ++ prog ++ " at "++ path) return res -- | Look for a program and try to find it's version number. It can accept -- either an absolute path or the name of a program binary, in which case we -- will look for the program on the path. -- findProgramVersion :: String -- ^ version args -> (String -> String) -- ^ function to select version -- number from program output -> Verbosity -> FilePath -- ^ location -> IO (Maybe Version) findProgramVersion versionArg selectVersion verbosity path = do str <- rawSystemStdout verbosity path [versionArg] `catchIO` (\_ -> return "") `catchExit` (\_ -> return "") let version :: Maybe Version version = simpleParse (selectVersion str) case version of Nothing -> warn verbosity $ "cannot determine version of " ++ path ++ " :\n" ++ show str Just v -> debug verbosity $ path ++ " is version " ++ display v return version -- | Like the Unix xargs program. Useful for when we've got very long command -- lines that might overflow an OS limit on command line length and so you -- need to invoke a command multiple times to get all the args in. -- -- Use it with either of the rawSystem variants above. For example: -- -- > xargs (32*1024) (rawSystemExit verbosity) prog fixedArgs bigArgs -- xargs :: Int -> ([String] -> IO ()) -> [String] -> [String] -> IO () xargs maxSize rawSystemFun fixedArgs bigArgs = let fixedArgSize = sum (map length fixedArgs) + length fixedArgs chunkSize = maxSize - fixedArgSize in mapM_ (rawSystemFun . (fixedArgs ++)) (chunks chunkSize bigArgs) where chunks len = unfoldr $ \s -> if null s then Nothing else Just (chunk [] len s) chunk acc _ [] = (reverse acc,[]) chunk acc len (s:ss) | len' < len = chunk (s:acc) (len-len'-1) ss | otherwise = (reverse acc, s:ss) where len' = length s -- ------------------------------------------------------------ -- * File Utilities -- ------------------------------------------------------------ ---------------- -- Finding files -- | Find a file by looking in a search path. The file path must match exactly. -- findFile :: [FilePath] -- ^search locations -> FilePath -- ^File Name -> IO FilePath findFile searchPath fileName = findFirstFile id [ path fileName | path <- nub searchPath] >>= maybe (die $ fileName ++ " doesn't exist") return -- | Find a file by looking in a search path with one of a list of possible -- file extensions. The file base name should be given and it will be tried -- with each of the extensions in each element of the search path. -- findFileWithExtension :: [String] -> [FilePath] -> FilePath -> IO (Maybe FilePath) findFileWithExtension extensions searchPath baseName = findFirstFile id [ path baseName <.> ext | path <- nub searchPath , ext <- nub extensions ] -- | Like 'findFileWithExtension' but returns which element of the search path -- the file was found in, and the file path relative to that base directory. -- findFileWithExtension' :: [String] -> [FilePath] -> FilePath -> IO (Maybe (FilePath, FilePath)) findFileWithExtension' extensions searchPath baseName = findFirstFile (uncurry ()) [ (path, baseName <.> ext) | path <- nub searchPath , ext <- nub extensions ] findFirstFile :: (a -> FilePath) -> [a] -> IO (Maybe a) findFirstFile file = findFirst where findFirst [] = return Nothing findFirst (x:xs) = do exists <- doesFileExist (file x) if exists then return (Just x) else findFirst xs -- | Finds the files corresponding to a list of Haskell module names. -- -- As 'findModuleFile' but for a list of module names. -- findModuleFiles :: [FilePath] -- ^ build prefix (location of objects) -> [String] -- ^ search suffixes -> [ModuleName] -- ^ modules -> IO [(FilePath, FilePath)] findModuleFiles searchPath extensions moduleNames = mapM (findModuleFile searchPath extensions) moduleNames -- | Find the file corresponding to a Haskell module name. -- -- This is similar to 'findFileWithExtension'' but specialised to a module -- name. The function fails if the file corresponding to the module is missing. -- findModuleFile :: [FilePath] -- ^ build prefix (location of objects) -> [String] -- ^ search suffixes -> ModuleName -- ^ module -> IO (FilePath, FilePath) findModuleFile searchPath extensions moduleName = maybe notFound return =<< findFileWithExtension' extensions searchPath (ModuleName.toFilePath moduleName) where notFound = die $ "Error: Could not find module: " ++ display moduleName ++ " with any suffix: " ++ show extensions ++ " in the search path: " ++ show searchPath -- | List all the files in a directory and all subdirectories. -- -- The order places files in sub-directories after all the files in their -- parent directories. The list is generated lazily so is not well defined if -- the source directory structure changes before the list is used. -- getDirectoryContentsRecursive :: FilePath -> IO [FilePath] getDirectoryContentsRecursive topdir = recurseDirectories [""] where recurseDirectories :: [FilePath] -> IO [FilePath] recurseDirectories [] = return [] recurseDirectories (dir:dirs) = unsafeInterleaveIO $ do (files, dirs') <- collect [] [] =<< getDirectoryContents (topdir dir) files' <- recurseDirectories (dirs' ++ dirs) return (files ++ files') where collect files dirs' [] = return (reverse files ,reverse dirs') collect files dirs' (entry:entries) | ignore entry = collect files dirs' entries collect files dirs' (entry:entries) = do let dirEntry = dir entry isDirectory <- doesDirectoryExist (topdir dirEntry) if isDirectory then collect files (dirEntry:dirs') entries else collect (dirEntry:files) dirs' entries ignore ['.'] = True ignore ['.', '.'] = True ignore _ = False ------------------------ -- Environment variables -- | Is this directory in the system search path? isInSearchPath :: FilePath -> IO Bool isInSearchPath path = fmap (elem path) getSearchPath addLibraryPath :: OS -> [FilePath] -> [(String,String)] -> [(String,String)] addLibraryPath os paths = addEnv where pathsString = intercalate [searchPathSeparator] paths ldPath = case os of OSX -> "DYLD_LIBRARY_PATH" _ -> "LD_LIBRARY_PATH" addEnv [] = [(ldPath,pathsString)] addEnv ((key,value):xs) | key == ldPath = if null value then (key,pathsString):xs else (key,value ++ (searchPathSeparator:pathsString)):xs | otherwise = (key,value):addEnv xs ---------------- -- File globbing data FileGlob -- | No glob at all, just an ordinary file = NoGlob FilePath -- | dir prefix and extension, like @\"foo\/bar\/\*.baz\"@ corresponds to -- @FileGlob \"foo\/bar\" \".baz\"@ | FileGlob FilePath String parseFileGlob :: FilePath -> Maybe FileGlob parseFileGlob filepath = case splitExtensions filepath of (filepath', ext) -> case splitFileName filepath' of (dir, "*") | '*' `elem` dir || '*' `elem` ext || null ext -> Nothing | null dir -> Just (FileGlob "." ext) | otherwise -> Just (FileGlob dir ext) _ | '*' `elem` filepath -> Nothing | otherwise -> Just (NoGlob filepath) matchFileGlob :: FilePath -> IO [FilePath] matchFileGlob = matchDirFileGlob "." matchDirFileGlob :: FilePath -> FilePath -> IO [FilePath] matchDirFileGlob dir filepath = case parseFileGlob filepath of Nothing -> die $ "invalid file glob '" ++ filepath ++ "'. Wildcards '*' are only allowed in place of the file" ++ " name, not in the directory name or file extension." ++ " If a wildcard is used it must be with an file extension." Just (NoGlob filepath') -> return [filepath'] Just (FileGlob dir' ext) -> do files <- getDirectoryContents (dir dir') case [ dir' file | file <- files , let (name, ext') = splitExtensions file , not (null name) && ext' == ext ] of [] -> die $ "filepath wildcard '" ++ filepath ++ "' does not match any files." matches -> return matches -------------------- -- Modification time -- | Compare the modification times of two files to see if the first is newer -- than the second. The first file must exist but the second need not. -- The expected use case is when the second file is generated using the first. -- In this use case, if the result is True then the second file is out of date. -- moreRecentFile :: FilePath -> FilePath -> IO Bool moreRecentFile a b = do exists <- doesFileExist b if not exists then return True else do tb <- getModificationTime b ta <- getModificationTime a return (ta > tb) -- | Like 'moreRecentFile', but also checks that the first file exists. existsAndIsMoreRecentThan :: FilePath -> FilePath -> IO Bool existsAndIsMoreRecentThan a b = do exists <- doesFileExist a if not exists then return False else a `moreRecentFile` b ---------------------------------------- -- Copying and installing files and dirs -- | Same as 'createDirectoryIfMissing' but logs at higher verbosity levels. -- createDirectoryIfMissingVerbose :: Verbosity -> Bool -- ^ Create its parents too? -> FilePath -> IO () createDirectoryIfMissingVerbose verbosity create_parents path0 | create_parents = createDirs (parents path0) | otherwise = createDirs (take 1 (parents path0)) where parents = reverse . scanl1 () . splitDirectories . normalise createDirs [] = return () createDirs (dir:[]) = createDir dir throwIO createDirs (dir:dirs) = createDir dir $ \_ -> do createDirs dirs createDir dir throwIO createDir :: FilePath -> (IOException -> IO ()) -> IO () createDir dir notExistHandler = do r <- tryIO $ createDirectoryVerbose verbosity dir case (r :: Either IOException ()) of Right () -> return () Left e | isDoesNotExistError e -> notExistHandler e -- createDirectory (and indeed POSIX mkdir) does not distinguish -- between a dir already existing and a file already existing. So we -- check for it here. Unfortunately there is a slight race condition -- here, but we think it is benign. It could report an exception in -- the case that the dir did exist but another process deletes the -- directory and creates a file in its place before we can check -- that the directory did indeed exist. | isAlreadyExistsError e -> (do isDir <- doesDirectoryExist dir if isDir then return () else throwIO e ) `catchIO` ((\_ -> return ()) :: IOException -> IO ()) | otherwise -> throwIO e createDirectoryVerbose :: Verbosity -> FilePath -> IO () createDirectoryVerbose verbosity dir = do info verbosity $ "creating " ++ dir createDirectory dir setDirOrdinary dir -- | Copies a file without copying file permissions. The target file is created -- with default permissions. Any existing target file is replaced. -- -- At higher verbosity levels it logs an info message. -- copyFileVerbose :: Verbosity -> FilePath -> FilePath -> IO () copyFileVerbose verbosity src dest = do info verbosity ("copy " ++ src ++ " to " ++ dest) copyFile src dest -- | Install an ordinary file. This is like a file copy but the permissions -- are set appropriately for an installed file. On Unix it is \"-rw-r--r--\" -- while on Windows it uses the default permissions for the target directory. -- installOrdinaryFile :: Verbosity -> FilePath -> FilePath -> IO () installOrdinaryFile verbosity src dest = do info verbosity ("Installing " ++ src ++ " to " ++ dest) copyOrdinaryFile src dest -- | Install an executable file. This is like a file copy but the permissions -- are set appropriately for an installed file. On Unix it is \"-rwxr-xr-x\" -- while on Windows it uses the default permissions for the target directory. -- installExecutableFile :: Verbosity -> FilePath -> FilePath -> IO () installExecutableFile verbosity src dest = do info verbosity ("Installing executable " ++ src ++ " to " ++ dest) copyExecutableFile src dest -- | Install a file that may or not be executable, preserving permissions. installMaybeExecutableFile :: Verbosity -> FilePath -> FilePath -> IO () installMaybeExecutableFile verbosity src dest = do perms <- getPermissions src if (executable perms) --only checks user x bit then installExecutableFile verbosity src dest else installOrdinaryFile verbosity src dest -- | Given a relative path to a file, copy it to the given directory, preserving -- the relative path and creating the parent directories if needed. copyFileTo :: Verbosity -> FilePath -> FilePath -> IO () copyFileTo verbosity dir file = do let targetFile = dir file createDirectoryIfMissingVerbose verbosity True (takeDirectory targetFile) installOrdinaryFile verbosity file targetFile -- | Common implementation of 'copyFiles', 'installOrdinaryFiles', -- 'installExecutableFiles' and 'installMaybeExecutableFiles'. copyFilesWith :: (Verbosity -> FilePath -> FilePath -> IO ()) -> Verbosity -> FilePath -> [(FilePath, FilePath)] -> IO () copyFilesWith doCopy verbosity targetDir srcFiles = do -- Create parent directories for everything let dirs = map (targetDir ) . nub . map (takeDirectory . snd) $ srcFiles mapM_ (createDirectoryIfMissingVerbose verbosity True) dirs -- Copy all the files sequence_ [ let src = srcBase srcFile dest = targetDir srcFile in doCopy verbosity src dest | (srcBase, srcFile) <- srcFiles ] -- | Copies a bunch of files to a target directory, preserving the directory -- structure in the target location. The target directories are created if they -- do not exist. -- -- The files are identified by a pair of base directory and a path relative to -- that base. It is only the relative part that is preserved in the -- destination. -- -- For example: -- -- > copyFiles normal "dist/src" -- > [("", "src/Foo.hs"), ("dist/build/", "src/Bar.hs")] -- -- This would copy \"src\/Foo.hs\" to \"dist\/src\/src\/Foo.hs\" and -- copy \"dist\/build\/src\/Bar.hs\" to \"dist\/src\/src\/Bar.hs\". -- -- This operation is not atomic. Any IO failure during the copy (including any -- missing source files) leaves the target in an unknown state so it is best to -- use it with a freshly created directory so that it can be simply deleted if -- anything goes wrong. -- copyFiles :: Verbosity -> FilePath -> [(FilePath, FilePath)] -> IO () copyFiles = copyFilesWith copyFileVerbose -- | This is like 'copyFiles' but uses 'installOrdinaryFile'. -- installOrdinaryFiles :: Verbosity -> FilePath -> [(FilePath, FilePath)] -> IO () installOrdinaryFiles = copyFilesWith installOrdinaryFile -- | This is like 'copyFiles' but uses 'installExecutableFile'. -- installExecutableFiles :: Verbosity -> FilePath -> [(FilePath, FilePath)] -> IO () installExecutableFiles = copyFilesWith installExecutableFile -- | This is like 'copyFiles' but uses 'installMaybeExecutableFile'. -- installMaybeExecutableFiles :: Verbosity -> FilePath -> [(FilePath, FilePath)] -> IO () installMaybeExecutableFiles = copyFilesWith installMaybeExecutableFile -- | This installs all the files in a directory to a target location, -- preserving the directory layout. All the files are assumed to be ordinary -- rather than executable files. -- installDirectoryContents :: Verbosity -> FilePath -> FilePath -> IO () installDirectoryContents verbosity srcDir destDir = do info verbosity ("copy directory '" ++ srcDir ++ "' to '" ++ destDir ++ "'.") srcFiles <- getDirectoryContentsRecursive srcDir installOrdinaryFiles verbosity destDir [ (srcDir, f) | f <- srcFiles ] -- | Recursively copy the contents of one directory to another path. copyDirectoryRecursive :: Verbosity -> FilePath -> FilePath -> IO () copyDirectoryRecursive verbosity srcDir destDir = do info verbosity ("copy directory '" ++ srcDir ++ "' to '" ++ destDir ++ "'.") srcFiles <- getDirectoryContentsRecursive srcDir copyFilesWith (const copyFile) verbosity destDir [ (srcDir, f) | f <- srcFiles ] ------------------- -- File permissions -- | Like 'doesFileExist', but also checks that the file is executable. doesExecutableExist :: FilePath -> IO Bool doesExecutableExist f = do exists <- doesFileExist f if exists then do perms <- getPermissions f return (executable perms) else return False --------------------------------- -- Deprecated file copy functions {-# DEPRECATED smartCopySources "Use findModuleFiles and copyFiles or installOrdinaryFiles" #-} smartCopySources :: Verbosity -> [FilePath] -> FilePath -> [ModuleName] -> [String] -> IO () smartCopySources verbosity searchPath targetDir moduleNames extensions = findModuleFiles searchPath extensions moduleNames >>= copyFiles verbosity targetDir {-# DEPRECATED copyDirectoryRecursiveVerbose "You probably want installDirectoryContents instead" #-} copyDirectoryRecursiveVerbose :: Verbosity -> FilePath -> FilePath -> IO () copyDirectoryRecursiveVerbose verbosity srcDir destDir = do info verbosity ("copy directory '" ++ srcDir ++ "' to '" ++ destDir ++ "'.") srcFiles <- getDirectoryContentsRecursive srcDir copyFiles verbosity destDir [ (srcDir, f) | f <- srcFiles ] --------------------------- -- Temporary files and dirs -- | Advanced options for 'withTempFile' and 'withTempDirectory'. data TempFileOptions = TempFileOptions { optKeepTempFiles :: Bool -- ^ Keep temporary files? } defaultTempFileOptions :: TempFileOptions defaultTempFileOptions = TempFileOptions { optKeepTempFiles = False } -- | Use a temporary filename that doesn't already exist. -- withTempFile :: FilePath -- ^ Temp dir to create the file in -> String -- ^ File name template. See 'openTempFile'. -> (FilePath -> Handle -> IO a) -> IO a withTempFile tmpDir template action = withTempFileEx defaultTempFileOptions tmpDir template action -- | A version of 'withTempFile' that additionally takes a 'TempFileOptions' -- argument. withTempFileEx :: TempFileOptions -> FilePath -- ^ Temp dir to create the file in -> String -- ^ File name template. See 'openTempFile'. -> (FilePath -> Handle -> IO a) -> IO a withTempFileEx opts tmpDir template action = Exception.bracket (openTempFile tmpDir template) (\(name, handle) -> do hClose handle unless (optKeepTempFiles opts) $ removeFile name) (uncurry action) -- | Create and use a temporary directory. -- -- Creates a new temporary directory inside the given directory, making use -- of the template. The temp directory is deleted after use. For example: -- -- > withTempDirectory verbosity "src" "sdist." $ \tmpDir -> do ... -- -- The @tmpDir@ will be a new subdirectory of the given directory, e.g. -- @src/sdist.342@. -- withTempDirectory :: Verbosity -> FilePath -> String -> (FilePath -> IO a) -> IO a withTempDirectory verbosity targetDir template = withTempDirectoryEx verbosity defaultTempFileOptions targetDir template -- | A version of 'withTempDirectory' that additionally takes a -- 'TempFileOptions' argument. withTempDirectoryEx :: Verbosity -> TempFileOptions -> FilePath -> String -> (FilePath -> IO a) -> IO a withTempDirectoryEx _verbosity opts targetDir template = Exception.bracket (createTempDirectory targetDir template) (unless (optKeepTempFiles opts) . removeDirectoryRecursive) ----------------------------------- -- Safely reading and writing files -- | Gets the contents of a file, but guarantee that it gets closed. -- -- The file is read lazily but if it is not fully consumed by the action then -- the remaining input is truncated and the file is closed. -- withFileContents :: FilePath -> (String -> IO a) -> IO a withFileContents name action = Exception.bracket (openFile name ReadMode) hClose (\hnd -> hGetContents hnd >>= action) -- | Writes a file atomically. -- -- The file is either written successfully or an IO exception is raised and -- the original file is left unchanged. -- -- On windows it is not possible to delete a file that is open by a process. -- This case will give an IO exception but the atomic property is not affected. -- writeFileAtomic :: FilePath -> BS.ByteString -> IO () writeFileAtomic targetPath content = do let (targetDir, targetFile) = splitFileName targetPath Exception.bracketOnError (openBinaryTempFileWithDefaultPermissions targetDir $ targetFile <.> "tmp") (\(tmpPath, handle) -> hClose handle >> removeFile tmpPath) (\(tmpPath, handle) -> do BS.hPut handle content hClose handle renameFile tmpPath targetPath) -- | Write a file but only if it would have new content. If we would be writing -- the same as the existing content then leave the file as is so that we do not -- update the file's modification time. -- -- NB: the file is assumed to be ASCII-encoded. rewriteFile :: FilePath -> String -> IO () rewriteFile path newContent = flip catchIO mightNotExist $ do existingContent <- readFile path _ <- evaluate (length existingContent) unless (existingContent == newContent) $ writeFileAtomic path (BS.Char8.pack newContent) where mightNotExist e | isDoesNotExistError e = writeFileAtomic path (BS.Char8.pack newContent) | otherwise = ioError e -- | The path name that represents the current directory. -- In Unix, it's @\".\"@, but this is system-specific. -- (E.g. AmigaOS uses the empty string @\"\"@ for the current directory.) currentDir :: FilePath currentDir = "." shortRelativePath :: FilePath -> FilePath -> FilePath shortRelativePath from to = case dropCommonPrefix (splitDirectories from) (splitDirectories to) of (stuff, path) -> joinPath (map (const "..") stuff ++ path) where dropCommonPrefix :: Eq a => [a] -> [a] -> ([a],[a]) dropCommonPrefix (x:xs) (y:ys) | x == y = dropCommonPrefix xs ys dropCommonPrefix xs ys = (xs,ys) -- ------------------------------------------------------------ -- * Finding the description file -- ------------------------------------------------------------ -- |Package description file (/pkgname/@.cabal@) defaultPackageDesc :: Verbosity -> IO FilePath defaultPackageDesc _verbosity = tryFindPackageDesc currentDir -- |Find a package description file in the given directory. Looks for -- @.cabal@ files. findPackageDesc :: FilePath -- ^Where to look -> IO (Either String FilePath) -- ^.cabal findPackageDesc dir = do files <- getDirectoryContents dir -- to make sure we do not mistake a ~/.cabal/ dir for a .cabal -- file we filter to exclude dirs and null base file names: cabalFiles <- filterM doesFileExist [ dir file | file <- files , let (name, ext) = splitExtension file , not (null name) && ext == ".cabal" ] case cabalFiles of [] -> return (Left noDesc) [cabalFile] -> return (Right cabalFile) multiple -> return (Left $ multiDesc multiple) where noDesc :: String noDesc = "No cabal file found.\n" ++ "Please create a package description file .cabal" multiDesc :: [String] -> String multiDesc l = "Multiple cabal files found.\n" ++ "Please use only one of: " ++ intercalate ", " l -- |Like 'findPackageDesc', but calls 'die' in case of error. tryFindPackageDesc :: FilePath -> IO FilePath tryFindPackageDesc dir = join . fmap (either die return) $ findPackageDesc dir -- |Optional auxiliary package information file (/pkgname/@.buildinfo@) defaultHookedPackageDesc :: IO (Maybe FilePath) defaultHookedPackageDesc = findHookedPackageDesc currentDir -- |Find auxiliary package information in the given directory. -- Looks for @.buildinfo@ files. findHookedPackageDesc :: FilePath -- ^Directory to search -> IO (Maybe FilePath) -- ^/dir/@\/@/pkgname/@.buildinfo@, if present findHookedPackageDesc dir = do files <- getDirectoryContents dir buildInfoFiles <- filterM doesFileExist [ dir file | file <- files , let (name, ext) = splitExtension file , not (null name) && ext == buildInfoExt ] case buildInfoFiles of [] -> return Nothing [f] -> return (Just f) _ -> die ("Multiple files with extension " ++ buildInfoExt) buildInfoExt :: String buildInfoExt = ".buildinfo" -- ------------------------------------------------------------ -- * Unicode stuff -- ------------------------------------------------------------ -- This is a modification of the UTF8 code from gtk2hs and the -- utf8-string package. fromUTF8 :: String -> String fromUTF8 [] = [] fromUTF8 (c:cs) | c <= '\x7F' = c : fromUTF8 cs | c <= '\xBF' = replacementChar : fromUTF8 cs | c <= '\xDF' = twoBytes c cs | c <= '\xEF' = moreBytes 3 0x800 cs (ord c .&. 0xF) | c <= '\xF7' = moreBytes 4 0x10000 cs (ord c .&. 0x7) | c <= '\xFB' = moreBytes 5 0x200000 cs (ord c .&. 0x3) | c <= '\xFD' = moreBytes 6 0x4000000 cs (ord c .&. 0x1) | otherwise = replacementChar : fromUTF8 cs where twoBytes c0 (c1:cs') | ord c1 .&. 0xC0 == 0x80 = let d = ((ord c0 .&. 0x1F) `shiftL` 6) .|. (ord c1 .&. 0x3F) in if d >= 0x80 then chr d : fromUTF8 cs' else replacementChar : fromUTF8 cs' twoBytes _ cs' = replacementChar : fromUTF8 cs' moreBytes :: Int -> Int -> [Char] -> Int -> [Char] moreBytes 1 overlong cs' acc | overlong <= acc && acc <= 0x10FFFF && (acc < 0xD800 || 0xDFFF < acc) && (acc < 0xFFFE || 0xFFFF < acc) = chr acc : fromUTF8 cs' | otherwise = replacementChar : fromUTF8 cs' moreBytes byteCount overlong (cn:cs') acc | ord cn .&. 0xC0 == 0x80 = moreBytes (byteCount-1) overlong cs' ((acc `shiftL` 6) .|. ord cn .&. 0x3F) moreBytes _ _ cs' _ = replacementChar : fromUTF8 cs' replacementChar = '\xfffd' toUTF8 :: String -> String toUTF8 [] = [] toUTF8 (c:cs) | c <= '\x07F' = c : toUTF8 cs | c <= '\x7FF' = chr (0xC0 .|. (w `shiftR` 6)) : chr (0x80 .|. (w .&. 0x3F)) : toUTF8 cs | c <= '\xFFFF'= chr (0xE0 .|. (w `shiftR` 12)) : chr (0x80 .|. ((w `shiftR` 6) .&. 0x3F)) : chr (0x80 .|. (w .&. 0x3F)) : toUTF8 cs | otherwise = chr (0xf0 .|. (w `shiftR` 18)) : chr (0x80 .|. ((w `shiftR` 12) .&. 0x3F)) : chr (0x80 .|. ((w `shiftR` 6) .&. 0x3F)) : chr (0x80 .|. (w .&. 0x3F)) : toUTF8 cs where w = ord c -- | Ignore a Unicode byte order mark (BOM) at the beginning of the input -- ignoreBOM :: String -> String ignoreBOM ('\xFEFF':string) = string ignoreBOM string = string -- | Reads a UTF8 encoded text file as a Unicode String -- -- Reads lazily using ordinary 'readFile'. -- readUTF8File :: FilePath -> IO String readUTF8File f = fmap (ignoreBOM . fromUTF8) . hGetContents =<< openBinaryFile f ReadMode -- | Reads a UTF8 encoded text file as a Unicode String -- -- Same behaviour as 'withFileContents'. -- withUTF8FileContents :: FilePath -> (String -> IO a) -> IO a withUTF8FileContents name action = Exception.bracket (openBinaryFile name ReadMode) hClose (\hnd -> hGetContents hnd >>= action . ignoreBOM . fromUTF8) -- | Writes a Unicode String as a UTF8 encoded text file. -- -- Uses 'writeFileAtomic', so provides the same guarantees. -- writeUTF8File :: FilePath -> String -> IO () writeUTF8File path = writeFileAtomic path . BS.Char8.pack . toUTF8 -- | Fix different systems silly line ending conventions normaliseLineEndings :: String -> String normaliseLineEndings [] = [] normaliseLineEndings ('\r':'\n':s) = '\n' : normaliseLineEndings s -- windows normaliseLineEndings ('\r':s) = '\n' : normaliseLineEndings s -- old OS X normaliseLineEndings ( c :s) = c : normaliseLineEndings s -- ------------------------------------------------------------ -- * Common utils -- ------------------------------------------------------------ -- | @dropWhileEndLE p@ is equivalent to @reverse . dropWhile p . reverse@, but -- quite a bit faster. The difference between "Data.List.dropWhileEnd" and this -- version is that the one in "Data.List" is strict in elements, but spine-lazy, -- while this one is spine-strict but lazy in elements. That's what @LE@ stands -- for - "lazy in elements". -- -- Example: -- -- @ -- > tail $ Data.List.dropWhileEnd (<3) [undefined, 5, 4, 3, 2, 1] -- *** Exception: Prelude.undefined -- > tail $ dropWhileEndLE (<3) [undefined, 5, 4, 3, 2, 1] -- [5,4,3] -- > take 3 $ Data.List.dropWhileEnd (<3) [5, 4, 3, 2, 1, undefined] -- [5,4,3] -- > take 3 $ dropWhileEndLE (<3) [5, 4, 3, 2, 1, undefined] -- *** Exception: Prelude.undefined -- @ dropWhileEndLE :: (a -> Bool) -> [a] -> [a] dropWhileEndLE p = foldr (\x r -> if null r && p x then [] else x:r) [] -- | @takeWhileEndLE p@ is equivalent to @reverse . takeWhile p . reverse@, but -- is usually faster (as well as being easier to read). takeWhileEndLE :: (a -> Bool) -> [a] -> [a] takeWhileEndLE p = fst . foldr go ([], False) where go x (rest, done) | not done && p x = (x:rest, False) | otherwise = (rest, True) -- | Like "Data.List.nub", but has @O(n log n)@ complexity instead of -- @O(n^2)@. Code for 'ordNub' and 'listUnion' taken from Niklas Hambüchen's -- package. ordNub :: (Ord a) => [a] -> [a] ordNub l = go Set.empty l where go _ [] = [] go s (x:xs) = if x `Set.member` s then go s xs else x : go (Set.insert x s) xs -- | Like "Data.List.union", but has @O(n log n)@ complexity instead of -- @O(n^2)@. listUnion :: (Ord a) => [a] -> [a] -> [a] listUnion a b = a ++ ordNub (filter (`Set.notMember` aSet) b) where aSet = Set.fromList a -- | A right-biased version of 'ordNub'. -- -- Example: -- -- @ -- > ordNub [1,2,1] -- [1,2] -- > ordNubRight [1,2,1] -- [2,1] -- @ ordNubRight :: (Ord a) => [a] -> [a] ordNubRight = fst . foldr go ([], Set.empty) where go x p@(l, s) = if x `Set.member` s then p else (x:l, Set.insert x s) -- | A right-biased version of 'listUnion'. -- -- Example: -- -- @ -- > listUnion [1,2,3,4,3] [2,1,1] -- [1,2,3,4,3] -- > listUnionRight [1,2,3,4,3] [2,1,1] -- [4,3,2,1,1] -- @ listUnionRight :: (Ord a) => [a] -> [a] -> [a] listUnionRight a b = ordNubRight (filter (`Set.notMember` bSet) a) ++ b where bSet = Set.fromList b equating :: Eq a => (b -> a) -> b -> b -> Bool equating p x y = p x == p y comparing :: Ord a => (b -> a) -> b -> b -> Ordering comparing p x y = p x `compare` p y isInfixOf :: String -> String -> Bool isInfixOf needle haystack = any (isPrefixOf needle) (tails haystack) lowercase :: String -> String lowercase = map Char.toLower Cabal-1.22.5.0/Distribution/Simple/Build/0000755000000000000000000000000012627136220016077 5ustar0000000000000000Cabal-1.22.5.0/Distribution/Simple/Build/Macros.hs0000644000000000000000000000755212627136220017670 0ustar0000000000000000----------------------------------------------------------------------------- -- | -- Module : Distribution.Simple.Build.Macros -- Copyright : Simon Marlow 2008 -- -- Maintainer : cabal-devel@haskell.org -- Portability : portable -- -- Generate cabal_macros.h - CPP macros for package version testing -- -- When using CPP you get -- -- > VERSION_ -- > MIN_VERSION_(A,B,C) -- -- for each /package/ in @build-depends@, which is true if the version of -- /package/ in use is @>= A.B.C@, using the normal ordering on version -- numbers. -- module Distribution.Simple.Build.Macros ( generate, generatePackageVersionMacros, ) where import Data.Maybe ( isJust ) import Distribution.Package ( PackageIdentifier(PackageIdentifier) ) import Distribution.Version ( Version(versionBranch) ) import Distribution.PackageDescription ( PackageDescription ) import Distribution.Simple.Compiler ( packageKeySupported ) import Distribution.Simple.LocalBuildInfo ( LocalBuildInfo(compiler, pkgKey, withPrograms), externalPackageDeps ) import Distribution.Simple.Program.Db ( configuredPrograms ) import Distribution.Simple.Program.Types ( ConfiguredProgram(programId, programVersion) ) import Distribution.Text ( display ) -- ------------------------------------------------------------ -- * Generate cabal_macros.h -- ------------------------------------------------------------ -- | The contents of the @cabal_macros.h@ for the given configured package. -- generate :: PackageDescription -> LocalBuildInfo -> String generate _pkg_descr lbi = "/* DO NOT EDIT: This file is automatically generated by Cabal */\n\n" ++ generatePackageVersionMacros (map snd (externalPackageDeps lbi)) ++ generateToolVersionMacros (configuredPrograms . withPrograms $ lbi) ++ generatePackageKeyMacro lbi -- | Helper function that generates just the @VERSION_pkg@ and @MIN_VERSION_pkg@ -- macros for a list of package ids (usually used with the specific deps of -- a configured package). -- generatePackageVersionMacros :: [PackageIdentifier] -> String generatePackageVersionMacros pkgids = concat [ "/* package " ++ display pkgid ++ " */\n" ++ generateMacros "" pkgname version | pkgid@(PackageIdentifier name version) <- pkgids , let pkgname = map fixchar (display name) ] -- | Helper function that generates just the @TOOL_VERSION_pkg@ and -- @MIN_TOOL_VERSION_pkg@ macros for a list of configured programs. -- generateToolVersionMacros :: [ConfiguredProgram] -> String generateToolVersionMacros progs = concat [ "/* tool " ++ progid ++ " */\n" ++ generateMacros "TOOL_" progname version | prog <- progs , isJust . programVersion $ prog , let progid = programId prog ++ "-" ++ display version progname = map fixchar (programId prog) Just version = programVersion prog ] -- | Common implementation of 'generatePackageVersionMacros' and -- 'generateToolVersionMacros'. -- generateMacros :: String -> String -> Version -> String generateMacros prefix name version = concat ["#define ", prefix, "VERSION_",name," ",show (display version),"\n" ,"#define MIN_", prefix, "VERSION_",name,"(major1,major2,minor) (\\\n" ," (major1) < ",major1," || \\\n" ," (major1) == ",major1," && (major2) < ",major2," || \\\n" ," (major1) == ",major1," && (major2) == ",major2," && (minor) <= ",minor,")" ,"\n\n" ] where (major1:major2:minor:_) = map show (versionBranch version ++ repeat 0) -- | Generate the @CURRENT_PACKAGE_KEY@ definition for the package key -- of the current package, if supported by the compiler generatePackageKeyMacro :: LocalBuildInfo -> String generatePackageKeyMacro lbi | packageKeySupported (compiler lbi) = "#define CURRENT_PACKAGE_KEY \"" ++ display (pkgKey lbi) ++ "\"\n\n" | otherwise = "" fixchar :: Char -> Char fixchar '-' = '_' fixchar c = c Cabal-1.22.5.0/Distribution/Simple/Build/PathsModule.hs0000644000000000000000000003034212627136220020662 0ustar0000000000000000----------------------------------------------------------------------------- -- | -- Module : Distribution.Simple.Build.Macros -- Copyright : Isaac Jones 2003-2005, -- Ross Paterson 2006, -- Duncan Coutts 2007-2008 -- -- Maintainer : cabal-devel@haskell.org -- Portability : portable -- -- Generating the Paths_pkgname module. -- -- This is a module that Cabal generates for the benefit of packages. It -- enables them to find their version number and find any installed data files -- at runtime. This code should probably be split off into another module. -- module Distribution.Simple.Build.PathsModule ( generate, pkgPathEnvVar ) where import Distribution.System ( OS(Windows), buildOS, Arch(..), buildArch ) import Distribution.Simple.Compiler ( CompilerFlavor(..), compilerFlavor, compilerVersion ) import Distribution.Package ( packageId, packageName, packageVersion ) import Distribution.PackageDescription ( PackageDescription(..), hasLibs ) import Distribution.Simple.LocalBuildInfo ( LocalBuildInfo(..), InstallDirs(..) , absoluteInstallDirs, prefixRelativeInstallDirs ) import Distribution.Simple.Setup ( CopyDest(NoCopyDest) ) import Distribution.Simple.BuildPaths ( autogenModuleName ) import Distribution.Simple.Utils ( shortRelativePath ) import Distribution.Text ( display ) import Distribution.Version ( Version(..), orLaterVersion, withinRange ) import System.FilePath ( pathSeparator ) import Data.Maybe ( fromJust, isNothing ) -- ------------------------------------------------------------ -- * Building Paths_.hs -- ------------------------------------------------------------ generate :: PackageDescription -> LocalBuildInfo -> String generate pkg_descr lbi = let pragmas | absolute = "" | supports_language_pragma = "{-# LANGUAGE ForeignFunctionInterface #-}\n" | otherwise = "{-# OPTIONS_GHC -fffi #-}\n"++ "{-# OPTIONS_JHC -fffi #-}\n" foreign_imports | absolute = "" | otherwise = "import Foreign\n"++ "import Foreign.C\n" reloc_imports | reloc = "import System.Environment (getExecutablePath)\n" | otherwise = "" header = pragmas++ "module " ++ display paths_modulename ++ " (\n"++ " version,\n"++ " getBinDir, getLibDir, getDataDir, getLibexecDir,\n"++ " getDataFileName, getSysconfDir\n"++ " ) where\n"++ "\n"++ foreign_imports++ "import qualified Control.Exception as Exception\n"++ "import Data.Version (Version(..))\n"++ "import System.Environment (getEnv)\n"++ reloc_imports ++ "import Prelude\n"++ "\n"++ "catchIO :: IO a -> (Exception.IOException -> IO a) -> IO a\n"++ "catchIO = Exception.catch\n" ++ "\n"++ "version :: Version"++ "\nversion = Version " ++ show branch ++ " " ++ show tags where Version branch tags = packageVersion pkg_descr body | reloc = "\n\nbindirrel :: FilePath\n" ++ "bindirrel = " ++ show flat_bindirreloc ++ "\n"++ "\ngetBinDir, getLibDir, getDataDir, getLibexecDir, getSysconfDir :: IO FilePath\n"++ "getBinDir = "++mkGetEnvOrReloc "bindir" flat_bindirreloc++"\n"++ "getLibDir = "++mkGetEnvOrReloc "libdir" flat_libdirreloc++"\n"++ "getDataDir = "++mkGetEnvOrReloc "datadir" flat_datadirreloc++"\n"++ "getLibexecDir = "++mkGetEnvOrReloc "libexecdir" flat_libexecdirreloc++"\n"++ "getSysconfDir = "++mkGetEnvOrReloc "sysconfdir" flat_sysconfdirreloc++"\n"++ "\n"++ "getDataFileName :: FilePath -> IO FilePath\n"++ "getDataFileName name = do\n"++ " dir <- getDataDir\n"++ " return (dir `joinFileName` name)\n"++ "\n"++ get_prefix_reloc_stuff++ "\n"++ filename_stuff | absolute = "\nbindir, libdir, datadir, libexecdir, sysconfdir :: FilePath\n"++ "\nbindir = " ++ show flat_bindir ++ "\nlibdir = " ++ show flat_libdir ++ "\ndatadir = " ++ show flat_datadir ++ "\nlibexecdir = " ++ show flat_libexecdir ++ "\nsysconfdir = " ++ show flat_sysconfdir ++ "\n"++ "\ngetBinDir, getLibDir, getDataDir, getLibexecDir, getSysconfDir :: IO FilePath\n"++ "getBinDir = "++mkGetEnvOr "bindir" "return bindir"++"\n"++ "getLibDir = "++mkGetEnvOr "libdir" "return libdir"++"\n"++ "getDataDir = "++mkGetEnvOr "datadir" "return datadir"++"\n"++ "getLibexecDir = "++mkGetEnvOr "libexecdir" "return libexecdir"++"\n"++ "getSysconfDir = "++mkGetEnvOr "sysconfdir" "return sysconfdir"++"\n"++ "\n"++ "getDataFileName :: FilePath -> IO FilePath\n"++ "getDataFileName name = do\n"++ " dir <- getDataDir\n"++ " return (dir ++ "++path_sep++" ++ name)\n" | otherwise = "\nprefix, bindirrel :: FilePath" ++ "\nprefix = " ++ show flat_prefix ++ "\nbindirrel = " ++ show (fromJust flat_bindirrel) ++ "\n\n"++ "getBinDir :: IO FilePath\n"++ "getBinDir = getPrefixDirRel bindirrel\n\n"++ "getLibDir :: IO FilePath\n"++ "getLibDir = "++mkGetDir flat_libdir flat_libdirrel++"\n\n"++ "getDataDir :: IO FilePath\n"++ "getDataDir = "++ mkGetEnvOr "datadir" (mkGetDir flat_datadir flat_datadirrel)++"\n\n"++ "getLibexecDir :: IO FilePath\n"++ "getLibexecDir = "++mkGetDir flat_libexecdir flat_libexecdirrel++"\n\n"++ "getSysconfDir :: IO FilePath\n"++ "getSysconfDir = "++mkGetDir flat_sysconfdir flat_sysconfdirrel++"\n\n"++ "getDataFileName :: FilePath -> IO FilePath\n"++ "getDataFileName name = do\n"++ " dir <- getDataDir\n"++ " return (dir `joinFileName` name)\n"++ "\n"++ get_prefix_stuff++ "\n"++ filename_stuff in header++body where InstallDirs { prefix = flat_prefix, bindir = flat_bindir, libdir = flat_libdir, datadir = flat_datadir, libexecdir = flat_libexecdir, sysconfdir = flat_sysconfdir } = absoluteInstallDirs pkg_descr lbi NoCopyDest InstallDirs { bindir = flat_bindirrel, libdir = flat_libdirrel, datadir = flat_datadirrel, libexecdir = flat_libexecdirrel, sysconfdir = flat_sysconfdirrel } = prefixRelativeInstallDirs (packageId pkg_descr) lbi flat_bindirreloc = shortRelativePath flat_prefix flat_bindir flat_libdirreloc = shortRelativePath flat_prefix flat_libdir flat_datadirreloc = shortRelativePath flat_prefix flat_datadir flat_libexecdirreloc = shortRelativePath flat_prefix flat_libexecdir flat_sysconfdirreloc = shortRelativePath flat_prefix flat_sysconfdir mkGetDir _ (Just dirrel) = "getPrefixDirRel " ++ show dirrel mkGetDir dir Nothing = "return " ++ show dir mkGetEnvOrReloc var dirrel = "catchIO (getEnv \""++var'++"\")" ++ " (\\_ -> getPrefixDirReloc \"" ++ dirrel ++ "\")" where var' = pkgPathEnvVar pkg_descr var mkGetEnvOr var expr = "catchIO (getEnv \""++var'++"\")"++ " (\\_ -> "++expr++")" where var' = pkgPathEnvVar pkg_descr var -- In several cases we cannot make relocatable installations absolute = hasLibs pkg_descr -- we can only make progs relocatable || isNothing flat_bindirrel -- if the bin dir is an absolute path || not (supportsRelocatableProgs (compilerFlavor (compiler lbi))) reloc = relocatable lbi supportsRelocatableProgs GHC = case buildOS of Windows -> True _ -> False supportsRelocatableProgs GHCJS = case buildOS of Windows -> True _ -> False supportsRelocatableProgs _ = False paths_modulename = autogenModuleName pkg_descr get_prefix_stuff = get_prefix_win32 buildArch path_sep = show [pathSeparator] supports_language_pragma = (compilerFlavor (compiler lbi) == GHC && (compilerVersion (compiler lbi) `withinRange` orLaterVersion (Version [6,6,1] []))) || compilerFlavor (compiler lbi) == GHCJS -- | Generates the name of the environment variable controlling the path -- component of interest. pkgPathEnvVar :: PackageDescription -> String -- ^ path component; one of \"bindir\", \"libdir\", -- \"datadir\", \"libexecdir\", or \"sysconfdir\" -> String -- ^ environment variable name pkgPathEnvVar pkg_descr var = showPkgName (packageName pkg_descr) ++ "_" ++ var where showPkgName = map fixchar . display fixchar '-' = '_' fixchar c = c get_prefix_reloc_stuff :: String get_prefix_reloc_stuff = "getPrefixDirReloc :: FilePath -> IO FilePath\n"++ "getPrefixDirReloc dirRel = do\n"++ " exePath <- getExecutablePath\n"++ " let (bindir,_) = splitFileName exePath\n"++ " return ((bindir `minusFileName` bindirrel) `joinFileName` dirRel)\n" get_prefix_win32 :: Arch -> String get_prefix_win32 arch = "getPrefixDirRel :: FilePath -> IO FilePath\n"++ "getPrefixDirRel dirRel = try_size 2048 -- plenty, PATH_MAX is 512 under Win32.\n"++ " where\n"++ " try_size size = allocaArray (fromIntegral size) $ \\buf -> do\n"++ " ret <- c_GetModuleFileName nullPtr buf size\n"++ " case ret of\n"++ " 0 -> return (prefix `joinFileName` dirRel)\n"++ " _ | ret < size -> do\n"++ " exePath <- peekCWString buf\n"++ " let (bindir,_) = splitFileName exePath\n"++ " return ((bindir `minusFileName` bindirrel) `joinFileName` dirRel)\n"++ " | otherwise -> try_size (size * 2)\n"++ "\n"++ "foreign import " ++ cconv ++ " unsafe \"windows.h GetModuleFileNameW\"\n"++ " c_GetModuleFileName :: Ptr () -> CWString -> Int32 -> IO Int32\n" where cconv = case arch of I386 -> "stdcall" X86_64 -> "ccall" _ -> error "win32 supported only with I386, X86_64" filename_stuff :: String filename_stuff = "minusFileName :: FilePath -> String -> FilePath\n"++ "minusFileName dir \"\" = dir\n"++ "minusFileName dir \".\" = dir\n"++ "minusFileName dir suffix =\n"++ " minusFileName (fst (splitFileName dir)) (fst (splitFileName suffix))\n"++ "\n"++ "joinFileName :: String -> String -> FilePath\n"++ "joinFileName \"\" fname = fname\n"++ "joinFileName \".\" fname = fname\n"++ "joinFileName dir \"\" = dir\n"++ "joinFileName dir fname\n"++ " | isPathSeparator (last dir) = dir++fname\n"++ " | otherwise = dir++pathSeparator:fname\n"++ "\n"++ "splitFileName :: FilePath -> (String, String)\n"++ "splitFileName p = (reverse (path2++drive), reverse fname)\n"++ " where\n"++ " (path,drive) = case p of\n"++ " (c:':':p') -> (reverse p',[':',c])\n"++ " _ -> (reverse p ,\"\")\n"++ " (fname,path1) = break isPathSeparator path\n"++ " path2 = case path1 of\n"++ " [] -> \".\"\n"++ " [_] -> path1 -- don't remove the trailing slash if \n"++ " -- there is only one character\n"++ " (c:path') | isPathSeparator c -> path'\n"++ " _ -> path1\n"++ "\n"++ "pathSeparator :: Char\n"++ (case buildOS of Windows -> "pathSeparator = '\\\\'\n" _ -> "pathSeparator = '/'\n") ++ "\n"++ "isPathSeparator :: Char -> Bool\n"++ (case buildOS of Windows -> "isPathSeparator c = c == '/' || c == '\\\\'\n" _ -> "isPathSeparator c = c == '/'\n") Cabal-1.22.5.0/Distribution/Simple/GHC/0000755000000000000000000000000012627136220015441 5ustar0000000000000000Cabal-1.22.5.0/Distribution/Simple/GHC/ImplInfo.hs0000644000000000000000000001100712627136220017511 0ustar0000000000000000----------------------------------------------------------------------------- -- | -- Module : Distribution.Simple.GHC.ImplInfo -- -- Maintainer : cabal-devel@haskell.org -- Portability : portable -- -- This module contains the data structure describing invocation -- details for a GHC or GHC-derived compiler, such as supported flags -- and workarounds for bugs. module Distribution.Simple.GHC.ImplInfo ( GhcImplInfo(..), getImplInfo, ghcVersionImplInfo, ghcjsVersionImplInfo, lhcVersionImplInfo ) where import Distribution.Simple.Compiler ( Compiler(..), CompilerFlavor(..) , compilerFlavor, compilerVersion, compilerCompatVersion ) import Distribution.Version ( Version(..) ) {- | Information about features and quirks of a GHC-based implementation. Compiler flavors based on GHC behave similarly enough that some of the support code for them is shared. Every implementation has its own peculiarities, that may or may not be a direct result of the underlying GHC version. This record keeps track of these differences. All shared code (i.e. everything not in the Distribution.Simple.FLAVOR module) should use implementation info rather than version numbers to test for supported features. -} data GhcImplInfo = GhcImplInfo { hasCcOdirBug :: Bool -- ^ bug in -odir handling for C compilations. , flagInfoLanguages :: Bool -- ^ --info and --supported-languages flags , fakeRecordPuns :: Bool -- ^ use -XRecordPuns for NamedFieldPuns , flagStubdir :: Bool -- ^ -stubdir flag supported , flagOutputDir :: Bool -- ^ -outputdir flag supported , noExtInSplitSuffix :: Bool -- ^ split-obj suffix does not contain p_o ext , flagFfiIncludes :: Bool -- ^ -#include on command line for FFI includes , flagBuildingCabalPkg :: Bool -- ^ -fbuilding-cabal-package flag supported , flagPackageId :: Bool -- ^ -package-id / -package flags supported , separateGccMingw :: Bool -- ^ mingw and gcc are in separate directories , supportsHaskell2010 :: Bool -- ^ -XHaskell2010 and -XHaskell98 flags , reportsNoExt :: Bool -- ^ --supported-languages gives Ext and NoExt , alwaysNondecIndent :: Bool -- ^ NondecreasingIndentation is always on , flagGhciScript :: Bool -- ^ -ghci-script flag supported , flagPackageConf :: Bool -- ^ use package-conf instead of package-db , flagDebugInfo :: Bool -- ^ -g flag supported } getImplInfo :: Compiler -> GhcImplInfo getImplInfo comp = case compilerFlavor comp of GHC -> ghcVersionImplInfo (compilerVersion comp) LHC -> lhcVersionImplInfo (compilerVersion comp) GHCJS -> case compilerCompatVersion GHC comp of Just ghcVer -> ghcjsVersionImplInfo (compilerVersion comp) ghcVer _ -> error ("Distribution.Simple.GHC.Props.getImplProps: " ++ "could not find GHC version for GHCJS compiler") x -> error ("Distribution.Simple.GHC.Props.getImplProps only works" ++ "for GHC-like compilers (GHC, GHCJS, LHC)" ++ ", but found " ++ show x) ghcVersionImplInfo :: Version -> GhcImplInfo ghcVersionImplInfo (Version v _) = GhcImplInfo { hasCcOdirBug = v < [6,4,1] , flagInfoLanguages = v >= [6,7] , fakeRecordPuns = v >= [6,8] && v < [6,10] , flagStubdir = v >= [6,8] , flagOutputDir = v >= [6,10] , noExtInSplitSuffix = v < [6,11] , flagFfiIncludes = v < [6,11] , flagBuildingCabalPkg = v >= [6,11] , flagPackageId = v > [6,11] , separateGccMingw = v < [6,12] , supportsHaskell2010 = v >= [7] , reportsNoExt = v >= [7] , alwaysNondecIndent = v < [7,1] , flagGhciScript = v >= [7,2] , flagPackageConf = v < [7,5] , flagDebugInfo = v >= [7,10] } ghcjsVersionImplInfo :: Version -> Version -> GhcImplInfo ghcjsVersionImplInfo _ghcjsVer _ghcVer = GhcImplInfo { hasCcOdirBug = False , flagInfoLanguages = True , fakeRecordPuns = False , flagStubdir = True , flagOutputDir = True , noExtInSplitSuffix = False , flagFfiIncludes = False , flagBuildingCabalPkg = True , flagPackageId = True , separateGccMingw = False , supportsHaskell2010 = True , reportsNoExt = True , alwaysNondecIndent = False , flagGhciScript = True , flagPackageConf = False , flagDebugInfo = False } lhcVersionImplInfo :: Version -> GhcImplInfo lhcVersionImplInfo = ghcVersionImplInfo Cabal-1.22.5.0/Distribution/Simple/GHC/Internal.hs0000644000000000000000000005331712627136220017562 0ustar0000000000000000{-# LANGUAGE CPP #-} ----------------------------------------------------------------------------- -- | -- Module : Distribution.Simple.GHC.Internal -- Copyright : Isaac Jones 2003-2007 -- -- Maintainer : cabal-devel@haskell.org -- Portability : portable -- -- This module contains functions shared by GHC (Distribution.Simple.GHC) -- and GHC-derived compilers. module Distribution.Simple.GHC.Internal ( configureToolchain, getLanguages, getExtensions, targetPlatform, getGhcInfo, componentCcGhcOptions, componentGhcOptions, mkGHCiLibName, filterGhciFlags, ghcLookupProperty, getHaskellObjects, mkGhcOptPackages, substTopDir, checkPackageDbEnvVar ) where import Distribution.Simple.GHC.ImplInfo ( GhcImplInfo (..) ) import Distribution.Package ( InstalledPackageId, PackageId ) import Distribution.InstalledPackageInfo ( InstalledPackageInfo ) import qualified Distribution.InstalledPackageInfo as InstalledPackageInfo ( InstalledPackageInfo_(..) ) import Distribution.PackageDescription as PD ( BuildInfo(..), Library(..), libModules , hcOptions, usedExtensions, ModuleRenaming, lookupRenaming ) import Distribution.Compat.Exception ( catchExit, catchIO ) import Distribution.Simple.Compiler ( CompilerFlavor(..), Compiler(..), DebugInfoLevel(..), OptimisationLevel(..) ) import Distribution.Simple.Program.GHC import Distribution.Simple.Setup ( toFlag ) import qualified Distribution.ModuleName as ModuleName import Distribution.Simple.Program ( Program(..), ConfiguredProgram(..), ProgramConfiguration , ProgramLocation(..), ProgramSearchPath, ProgramSearchPathEntry(..) , rawSystemProgram, rawSystemProgramStdout, programPath , addKnownProgram, arProgram, ldProgram, gccProgram, stripProgram , getProgramOutput ) import Distribution.Simple.Program.Types ( suppressOverrideArgs ) import Distribution.Simple.LocalBuildInfo ( LocalBuildInfo(..), ComponentLocalBuildInfo(..) , LibraryName(..) ) import Distribution.Simple.Utils import Distribution.Simple.BuildPaths import Distribution.System ( buildOS, OS(..), Platform, platformFromTriple ) import Distribution.Text ( display, simpleParse ) import Distribution.Utils.NubList ( toNubListR ) import Distribution.Verbosity import Language.Haskell.Extension ( Language(..), Extension(..), KnownExtension(..) ) import qualified Data.Map as M import Data.Char ( isSpace ) import Data.Maybe ( fromMaybe, maybeToList, isJust ) import Control.Monad ( unless, when ) #if __GLASGOW_HASKELL__ < 710 import Data.Monoid ( Monoid(..) ) #endif import System.Directory ( getDirectoryContents, getTemporaryDirectory ) import System.Environment ( getEnv ) import System.FilePath ( (), (<.>), takeExtension, takeDirectory ) import System.IO ( hClose, hPutStrLn ) targetPlatform :: [(String, String)] -> Maybe Platform targetPlatform ghcInfo = platformFromTriple =<< lookup "Target platform" ghcInfo -- | Adjust the way we find and configure gcc and ld -- configureToolchain :: GhcImplInfo -> ConfiguredProgram -> M.Map String String -> ProgramConfiguration -> ProgramConfiguration configureToolchain implInfo ghcProg ghcInfo = addKnownProgram gccProgram { programFindLocation = findProg gccProgram extraGccPath, programPostConf = configureGcc } . addKnownProgram ldProgram { programFindLocation = findProg ldProgram extraLdPath, programPostConf = configureLd } . addKnownProgram arProgram { programFindLocation = findProg arProgram extraArPath } . addKnownProgram stripProgram { programFindLocation = findProg stripProgram extraStripPath } where compilerDir = takeDirectory (programPath ghcProg) baseDir = takeDirectory compilerDir mingwBinDir = baseDir "mingw" "bin" libDir = baseDir "gcc-lib" includeDir = baseDir "include" "mingw" isWindows = case buildOS of Windows -> True; _ -> False binPrefix = "" mkExtraPath :: Maybe FilePath -> FilePath -> [FilePath] mkExtraPath mbPath mingwPath | isWindows = mbDir ++ [mingwPath] | otherwise = mbDir where mbDir = maybeToList . fmap takeDirectory $ mbPath extraGccPath = mkExtraPath mbGccLocation windowsExtraGccDir extraLdPath = mkExtraPath mbLdLocation windowsExtraLdDir extraArPath = mkExtraPath mbArLocation windowsExtraArDir extraStripPath = mkExtraPath mbStripLocation windowsExtraStripDir -- on Windows finding and configuring ghc's gcc & binutils is a bit special (windowsExtraGccDir, windowsExtraLdDir, windowsExtraArDir, windowsExtraStripDir) | separateGccMingw implInfo = (baseDir, libDir, libDir, libDir) | otherwise = -- GHC >= 6.12 let b = mingwBinDir binPrefix in (b, b, b, b) findProg :: Program -> [FilePath] -> Verbosity -> ProgramSearchPath -> IO (Maybe FilePath) findProg prog extraPath v searchpath = programFindLocation prog v searchpath' where searchpath' = (map ProgramSearchPathDir extraPath) ++ searchpath -- Read tool locations from the 'ghc --info' output. Useful when -- cross-compiling. mbGccLocation = M.lookup "C compiler command" ghcInfo mbLdLocation = M.lookup "ld command" ghcInfo mbArLocation = M.lookup "ar command" ghcInfo mbStripLocation = M.lookup "strip command" ghcInfo ccFlags = getFlags "C compiler flags" gccLinkerFlags = getFlags "Gcc Linker flags" ldLinkerFlags = getFlags "Ld Linker flags" getFlags key = case M.lookup key ghcInfo of Nothing -> [] Just flags -> case reads flags of [(args, "")] -> args _ -> [] -- XXX Should should be an error really configureGcc :: Verbosity -> ConfiguredProgram -> IO ConfiguredProgram configureGcc v gccProg = do gccProg' <- configureGcc' v gccProg return gccProg' { programDefaultArgs = programDefaultArgs gccProg' ++ ccFlags ++ gccLinkerFlags } configureGcc' :: Verbosity -> ConfiguredProgram -> IO ConfiguredProgram configureGcc' | isWindows = \_ gccProg -> case programLocation gccProg of -- if it's found on system then it means we're using the result -- of programFindLocation above rather than a user-supplied path -- Pre GHC 6.12, that meant we should add these flags to tell -- ghc's gcc where it lives and thus where gcc can find its -- various files: FoundOnSystem {} | separateGccMingw implInfo -> return gccProg { programDefaultArgs = ["-B" ++ libDir, "-I" ++ includeDir] } _ -> return gccProg | otherwise = \_ gccProg -> return gccProg configureLd :: Verbosity -> ConfiguredProgram -> IO ConfiguredProgram configureLd v ldProg = do ldProg' <- configureLd' v ldProg return ldProg' { programDefaultArgs = programDefaultArgs ldProg' ++ ldLinkerFlags } -- we need to find out if ld supports the -x flag configureLd' :: Verbosity -> ConfiguredProgram -> IO ConfiguredProgram configureLd' verbosity ldProg = do tempDir <- getTemporaryDirectory ldx <- withTempFile tempDir ".c" $ \testcfile testchnd -> withTempFile tempDir ".o" $ \testofile testohnd -> do hPutStrLn testchnd "int foo() { return 0; }" hClose testchnd; hClose testohnd rawSystemProgram verbosity ghcProg ["-c", testcfile, "-o", testofile] withTempFile tempDir ".o" $ \testofile' testohnd' -> do hClose testohnd' _ <- rawSystemProgramStdout verbosity ldProg ["-x", "-r", testofile, "-o", testofile'] return True `catchIO` (\_ -> return False) `catchExit` (\_ -> return False) if ldx then return ldProg { programDefaultArgs = ["-x"] } else return ldProg getLanguages :: Verbosity -> GhcImplInfo -> ConfiguredProgram -> IO [(Language, String)] getLanguages _ implInfo _ -- TODO: should be using --supported-languages rather than hard coding | supportsHaskell2010 implInfo = return [(Haskell98, "-XHaskell98") ,(Haskell2010, "-XHaskell2010")] | otherwise = return [(Haskell98, "")] getGhcInfo :: Verbosity -> GhcImplInfo -> ConfiguredProgram -> IO [(String, String)] getGhcInfo verbosity implInfo ghcProg | flagInfoLanguages implInfo = do xs <- getProgramOutput verbosity (suppressOverrideArgs ghcProg) ["--info"] case reads xs of [(i, ss)] | all isSpace ss -> return i _ -> die "Can't parse --info output of GHC" | otherwise = return [] getExtensions :: Verbosity -> GhcImplInfo -> ConfiguredProgram -> IO [(Extension, String)] getExtensions verbosity implInfo ghcProg | flagInfoLanguages implInfo = do str <- getProgramOutput verbosity (suppressOverrideArgs ghcProg) ["--supported-languages"] let extStrs = if reportsNoExt implInfo then lines str else -- Older GHCs only gave us either Foo or NoFoo, -- so we have to work out the other one ourselves [ extStr'' | extStr <- lines str , let extStr' = case extStr of 'N' : 'o' : xs -> xs _ -> "No" ++ extStr , extStr'' <- [extStr, extStr'] ] let extensions0 = [ (ext, "-X" ++ display ext) | Just ext <- map simpleParse extStrs ] extensions1 = if fakeRecordPuns implInfo then -- ghc-6.8 introduced RecordPuns however it -- should have been NamedFieldPuns. We now -- encourage packages to use NamedFieldPuns -- so for compatibility we fake support for -- it in ghc-6.8 by making it an alias for -- the old RecordPuns extension. (EnableExtension NamedFieldPuns, "-XRecordPuns") : (DisableExtension NamedFieldPuns, "-XNoRecordPuns") : extensions0 else extensions0 extensions2 = if alwaysNondecIndent implInfo then -- ghc-7.2 split NondecreasingIndentation off -- into a proper extension. Before that it -- was always on. (EnableExtension NondecreasingIndentation, "") : (DisableExtension NondecreasingIndentation, "") : extensions1 else extensions1 return extensions2 | otherwise = return oldLanguageExtensions -- | For GHC 6.6.x and earlier, the mapping from supported extensions to flags oldLanguageExtensions :: [(Extension, String)] oldLanguageExtensions = let doFlag (f, (enable, disable)) = [(EnableExtension f, enable), (DisableExtension f, disable)] fglasgowExts = ("-fglasgow-exts", "") -- This is wrong, but we don't want to turn -- all the extensions off when asked to just -- turn one off fFlag flag = ("-f" ++ flag, "-fno-" ++ flag) in concatMap doFlag [(OverlappingInstances , fFlag "allow-overlapping-instances") ,(TypeSynonymInstances , fglasgowExts) ,(TemplateHaskell , fFlag "th") ,(ForeignFunctionInterface , fFlag "ffi") ,(MonomorphismRestriction , fFlag "monomorphism-restriction") ,(MonoPatBinds , fFlag "mono-pat-binds") ,(UndecidableInstances , fFlag "allow-undecidable-instances") ,(IncoherentInstances , fFlag "allow-incoherent-instances") ,(Arrows , fFlag "arrows") ,(Generics , fFlag "generics") ,(ImplicitPrelude , fFlag "implicit-prelude") ,(ImplicitParams , fFlag "implicit-params") ,(CPP , ("-cpp", ""{- Wrong -})) ,(BangPatterns , fFlag "bang-patterns") ,(KindSignatures , fglasgowExts) ,(RecursiveDo , fglasgowExts) ,(ParallelListComp , fglasgowExts) ,(MultiParamTypeClasses , fglasgowExts) ,(FunctionalDependencies , fglasgowExts) ,(Rank2Types , fglasgowExts) ,(RankNTypes , fglasgowExts) ,(PolymorphicComponents , fglasgowExts) ,(ExistentialQuantification , fglasgowExts) ,(ScopedTypeVariables , fFlag "scoped-type-variables") ,(FlexibleContexts , fglasgowExts) ,(FlexibleInstances , fglasgowExts) ,(EmptyDataDecls , fglasgowExts) ,(PatternGuards , fglasgowExts) ,(GeneralizedNewtypeDeriving , fglasgowExts) ,(MagicHash , fglasgowExts) ,(UnicodeSyntax , fglasgowExts) ,(PatternSignatures , fglasgowExts) ,(UnliftedFFITypes , fglasgowExts) ,(LiberalTypeSynonyms , fglasgowExts) ,(TypeOperators , fglasgowExts) ,(GADTs , fglasgowExts) ,(RelaxedPolyRec , fglasgowExts) ,(ExtendedDefaultRules , fFlag "extended-default-rules") ,(UnboxedTuples , fglasgowExts) ,(DeriveDataTypeable , fglasgowExts) ,(ConstrainedClassMethods , fglasgowExts) ] componentCcGhcOptions :: Verbosity -> GhcImplInfo -> LocalBuildInfo -> BuildInfo -> ComponentLocalBuildInfo -> FilePath -> FilePath -> GhcOptions componentCcGhcOptions verbosity implInfo lbi bi clbi pref filename = mempty { ghcOptVerbosity = toFlag verbosity, ghcOptMode = toFlag GhcModeCompile, ghcOptInputFiles = toNubListR [filename], ghcOptCppIncludePath = toNubListR $ [autogenModulesDir lbi, odir] ++ PD.includeDirs bi, ghcOptPackageDBs = withPackageDB lbi, ghcOptPackages = toNubListR $ mkGhcOptPackages clbi, ghcOptCcOptions = toNubListR $ (case withOptimization lbi of NoOptimisation -> [] _ -> ["-O2"]) ++ (case withDebugInfo lbi of NoDebugInfo -> [] MinimalDebugInfo -> ["-g1"] NormalDebugInfo -> ["-g"] MaximalDebugInfo -> ["-g3"]) ++ PD.ccOptions bi, ghcOptObjDir = toFlag odir } where odir | hasCcOdirBug implInfo = pref takeDirectory filename | otherwise = pref -- ghc 6.4.0 had a bug in -odir handling for C compilations. componentGhcOptions :: Verbosity -> LocalBuildInfo -> BuildInfo -> ComponentLocalBuildInfo -> FilePath -> GhcOptions componentGhcOptions verbosity lbi bi clbi odir = mempty { ghcOptVerbosity = toFlag verbosity, ghcOptHideAllPackages = toFlag True, ghcOptCabal = toFlag True, ghcOptPackageDBs = withPackageDB lbi, ghcOptPackages = toNubListR $ mkGhcOptPackages clbi, ghcOptSplitObjs = toFlag (splitObjs lbi), ghcOptSourcePathClear = toFlag True, ghcOptSourcePath = toNubListR $ [odir] ++ (hsSourceDirs bi) ++ [autogenModulesDir lbi], ghcOptCppIncludePath = toNubListR $ [autogenModulesDir lbi, odir] ++ PD.includeDirs bi, ghcOptCppOptions = toNubListR $ cppOptions bi, ghcOptCppIncludes = toNubListR $ [autogenModulesDir lbi cppHeaderName], ghcOptFfiIncludes = toNubListR $ PD.includes bi, ghcOptObjDir = toFlag odir, ghcOptHiDir = toFlag odir, ghcOptStubDir = toFlag odir, ghcOptOutputDir = toFlag odir, ghcOptOptimisation = toGhcOptimisation (withOptimization lbi), ghcOptDebugInfo = toGhcDebugInfo (withDebugInfo lbi), ghcOptExtra = toNubListR $ hcOptions GHC bi, ghcOptLanguage = toFlag (fromMaybe Haskell98 (defaultLanguage bi)), -- Unsupported extensions have already been checked by configure ghcOptExtensions = toNubListR $ usedExtensions bi, ghcOptExtensionMap = M.fromList . compilerExtensions $ (compiler lbi) } where toGhcOptimisation NoOptimisation = mempty --TODO perhaps override? toGhcOptimisation NormalOptimisation = toFlag GhcNormalOptimisation toGhcOptimisation MaximumOptimisation = toFlag GhcMaximumOptimisation -- GHC doesn't support debug info levels yet. toGhcDebugInfo NoDebugInfo = mempty toGhcDebugInfo MinimalDebugInfo = toFlag True toGhcDebugInfo NormalDebugInfo = toFlag True toGhcDebugInfo MaximalDebugInfo = toFlag True -- | Strip out flags that are not supported in ghci filterGhciFlags :: [String] -> [String] filterGhciFlags = filter supported where supported ('-':'O':_) = False supported "-debug" = False supported "-threaded" = False supported "-ticky" = False supported "-eventlog" = False supported "-prof" = False supported "-unreg" = False supported _ = True mkGHCiLibName :: LibraryName -> String mkGHCiLibName (LibraryName lib) = lib <.> "o" ghcLookupProperty :: String -> Compiler -> Bool ghcLookupProperty prop comp = case M.lookup prop (compilerProperties comp) of Just "YES" -> True _ -> False -- when using -split-objs, we need to search for object files in the -- Module_split directory for each module. getHaskellObjects :: GhcImplInfo -> Library -> LocalBuildInfo -> FilePath -> String -> Bool -> IO [FilePath] getHaskellObjects implInfo lib lbi pref wanted_obj_ext allow_split_objs | splitObjs lbi && allow_split_objs = do let splitSuffix = if noExtInSplitSuffix implInfo then "_split" else "_" ++ wanted_obj_ext ++ "_split" dirs = [ pref (ModuleName.toFilePath x ++ splitSuffix) | x <- libModules lib ] objss <- mapM getDirectoryContents dirs let objs = [ dir obj | (objs',dir) <- zip objss dirs, obj <- objs', let obj_ext = takeExtension obj, '.':wanted_obj_ext == obj_ext ] return objs | otherwise = return [ pref ModuleName.toFilePath x <.> wanted_obj_ext | x <- libModules lib ] mkGhcOptPackages :: ComponentLocalBuildInfo -> [(InstalledPackageId, PackageId, ModuleRenaming)] mkGhcOptPackages clbi = map (\(i,p) -> (i,p,lookupRenaming p (componentPackageRenaming clbi))) (componentPackageDeps clbi) substTopDir :: FilePath -> InstalledPackageInfo -> InstalledPackageInfo substTopDir topDir ipo = ipo { InstalledPackageInfo.importDirs = map f (InstalledPackageInfo.importDirs ipo), InstalledPackageInfo.libraryDirs = map f (InstalledPackageInfo.libraryDirs ipo), InstalledPackageInfo.includeDirs = map f (InstalledPackageInfo.includeDirs ipo), InstalledPackageInfo.frameworkDirs = map f (InstalledPackageInfo.frameworkDirs ipo), InstalledPackageInfo.haddockInterfaces = map f (InstalledPackageInfo.haddockInterfaces ipo), InstalledPackageInfo.haddockHTMLs = map f (InstalledPackageInfo.haddockHTMLs ipo) } where f ('$':'t':'o':'p':'d':'i':'r':rest) = topDir ++ rest f x = x -- Cabal does not use the environment variable GHC{,JS}_PACKAGE_PATH; let -- users know that this is the case. See ticket #335. Simply ignoring it is -- not a good idea, since then ghc and cabal are looking at different sets -- of package DBs and chaos is likely to ensue. -- -- An exception to this is when running cabal from within a `cabal exec` -- environment. In this case, `cabal exec` will set the -- CABAL_SANDBOX_PACKAGE_PATH to the same value that it set -- GHC{,JS}_PACKAGE_PATH to. If that is the case it is OK to allow -- GHC{,JS}_PACKAGE_PATH. checkPackageDbEnvVar :: String -> String -> IO () checkPackageDbEnvVar compilerName packagePathEnvVar = do mPP <- lookupEnv packagePathEnvVar when (isJust mPP) $ do mcsPP <- lookupEnv "CABAL_SANDBOX_PACKAGE_PATH" unless (mPP == mcsPP) abort where lookupEnv :: String -> IO (Maybe String) lookupEnv name = (Just `fmap` getEnv name) `catchIO` const (return Nothing) abort = die $ "Use of " ++ compilerName ++ "'s environment variable " ++ packagePathEnvVar ++ " is incompatible with Cabal. Use the " ++ "flag --package-db to specify a package database (it can be " ++ "used multiple times)." Cabal-1.22.5.0/Distribution/Simple/GHC/IPI641.hs0000644000000000000000000001037312627136220016655 0ustar0000000000000000----------------------------------------------------------------------------- -- | -- Module : Distribution.Simple.GHC.IPI641 -- Copyright : (c) The University of Glasgow 2004 -- License : BSD3 -- -- Maintainer : cabal-devel@haskell.org -- Portability : portable -- module Distribution.Simple.GHC.IPI641 ( InstalledPackageInfo(..), toCurrent, ) where import qualified Distribution.InstalledPackageInfo as Current import qualified Distribution.Package as Current hiding (depends, installedPackageId) import Distribution.Text (display) import Distribution.Simple.GHC.IPI642 ( PackageIdentifier, convertPackageId , License, convertLicense, convertModuleName ) -- | This is the InstalledPackageInfo type used by ghc-6.4 and 6.4.1. -- -- It's here purely for the 'Read' instance so that we can read the package -- database used by those ghc versions. It is a little hacky to read the -- package db directly, but we do need the info and until ghc-6.9 there was -- no better method. -- -- In ghc-6.4.2 the format changed a bit. See "Distribution.Simple.GHC.IPI642" -- data InstalledPackageInfo = InstalledPackageInfo { package :: PackageIdentifier, license :: License, copyright :: String, maintainer :: String, author :: String, stability :: String, homepage :: String, pkgUrl :: String, description :: String, category :: String, exposed :: Bool, exposedModules :: [String], hiddenModules :: [String], importDirs :: [FilePath], libraryDirs :: [FilePath], hsLibraries :: [String], extraLibraries :: [String], includeDirs :: [FilePath], includes :: [String], depends :: [PackageIdentifier], hugsOptions :: [String], ccOptions :: [String], ldOptions :: [String], frameworkDirs :: [FilePath], frameworks :: [String], haddockInterfaces :: [FilePath], haddockHTMLs :: [FilePath] } deriving Read mkInstalledPackageId :: Current.PackageIdentifier -> Current.InstalledPackageId mkInstalledPackageId = Current.InstalledPackageId . display toCurrent :: InstalledPackageInfo -> Current.InstalledPackageInfo toCurrent ipi@InstalledPackageInfo{} = let pid = convertPackageId (package ipi) mkExposedModule m = Current.ExposedModule m Nothing Nothing in Current.InstalledPackageInfo { Current.installedPackageId = mkInstalledPackageId (convertPackageId (package ipi)), Current.sourcePackageId = pid, Current.packageKey = Current.OldPackageKey pid, Current.license = convertLicense (license ipi), Current.copyright = copyright ipi, Current.maintainer = maintainer ipi, Current.author = author ipi, Current.stability = stability ipi, Current.homepage = homepage ipi, Current.pkgUrl = pkgUrl ipi, Current.synopsis = "", Current.description = description ipi, Current.category = category ipi, Current.exposed = exposed ipi, Current.exposedModules = map (mkExposedModule . convertModuleName) (exposedModules ipi), Current.instantiatedWith = [], Current.hiddenModules = map convertModuleName (hiddenModules ipi), Current.trusted = Current.trusted Current.emptyInstalledPackageInfo, Current.importDirs = importDirs ipi, Current.libraryDirs = libraryDirs ipi, Current.dataDir = "", Current.hsLibraries = hsLibraries ipi, Current.extraLibraries = extraLibraries ipi, Current.extraGHCiLibraries = [], Current.includeDirs = includeDirs ipi, Current.includes = includes ipi, Current.depends = map (mkInstalledPackageId.convertPackageId) (depends ipi), Current.ccOptions = ccOptions ipi, Current.ldOptions = ldOptions ipi, Current.frameworkDirs = frameworkDirs ipi, Current.frameworks = frameworks ipi, Current.haddockInterfaces = haddockInterfaces ipi, Current.haddockHTMLs = haddockHTMLs ipi, Current.pkgRoot = Nothing } Cabal-1.22.5.0/Distribution/Simple/GHC/IPI642.hs0000644000000000000000000001255612627136220016663 0ustar0000000000000000----------------------------------------------------------------------------- -- | -- Module : Distribution.Simple.GHC.IPI642 -- Copyright : (c) The University of Glasgow 2004 -- License : BSD3 -- -- Maintainer : cabal-devel@haskell.org -- Portability : portable -- module Distribution.Simple.GHC.IPI642 ( InstalledPackageInfo(..), toCurrent, -- Don't use these, they're only for conversion purposes PackageIdentifier, convertPackageId, License, convertLicense, convertModuleName ) where import qualified Distribution.InstalledPackageInfo as Current import qualified Distribution.Package as Current hiding (depends, installedPackageId) import qualified Distribution.License as Current import Distribution.Version (Version) import Distribution.ModuleName (ModuleName) import Distribution.Text (simpleParse,display) import Data.Maybe -- | This is the InstalledPackageInfo type used by ghc-6.4.2 and later. -- -- It's here purely for the 'Read' instance so that we can read the package -- database used by those ghc versions. It is a little hacky to read the -- package db directly, but we do need the info and until ghc-6.9 there was -- no better method. -- -- In ghc-6.4.1 and before the format was slightly different. -- See "Distribution.Simple.GHC.IPI642" -- data InstalledPackageInfo = InstalledPackageInfo { package :: PackageIdentifier, license :: License, copyright :: String, maintainer :: String, author :: String, stability :: String, homepage :: String, pkgUrl :: String, description :: String, category :: String, exposed :: Bool, exposedModules :: [String], hiddenModules :: [String], importDirs :: [FilePath], libraryDirs :: [FilePath], hsLibraries :: [String], extraLibraries :: [String], extraGHCiLibraries:: [String], includeDirs :: [FilePath], includes :: [String], depends :: [PackageIdentifier], hugsOptions :: [String], ccOptions :: [String], ldOptions :: [String], frameworkDirs :: [FilePath], frameworks :: [String], haddockInterfaces :: [FilePath], haddockHTMLs :: [FilePath] } deriving Read data PackageIdentifier = PackageIdentifier { pkgName :: String, pkgVersion :: Version } deriving Read data License = GPL | LGPL | BSD3 | BSD4 | PublicDomain | AllRightsReserved | OtherLicense deriving Read convertPackageId :: PackageIdentifier -> Current.PackageIdentifier convertPackageId PackageIdentifier { pkgName = n, pkgVersion = v } = Current.PackageIdentifier (Current.PackageName n) v mkInstalledPackageId :: Current.PackageIdentifier -> Current.InstalledPackageId mkInstalledPackageId = Current.InstalledPackageId . display convertModuleName :: String -> ModuleName convertModuleName s = fromJust $ simpleParse s convertLicense :: License -> Current.License convertLicense GPL = Current.GPL Nothing convertLicense LGPL = Current.LGPL Nothing convertLicense BSD3 = Current.BSD3 convertLicense BSD4 = Current.BSD4 convertLicense PublicDomain = Current.PublicDomain convertLicense AllRightsReserved = Current.AllRightsReserved convertLicense OtherLicense = Current.OtherLicense toCurrent :: InstalledPackageInfo -> Current.InstalledPackageInfo toCurrent ipi@InstalledPackageInfo{} = let pid = convertPackageId (package ipi) mkExposedModule m = Current.ExposedModule m Nothing Nothing in Current.InstalledPackageInfo { Current.installedPackageId = mkInstalledPackageId (convertPackageId (package ipi)), Current.sourcePackageId = pid, Current.packageKey = Current.OldPackageKey pid, Current.license = convertLicense (license ipi), Current.copyright = copyright ipi, Current.maintainer = maintainer ipi, Current.author = author ipi, Current.stability = stability ipi, Current.homepage = homepage ipi, Current.pkgUrl = pkgUrl ipi, Current.synopsis = "", Current.description = description ipi, Current.category = category ipi, Current.exposed = exposed ipi, Current.exposedModules = map (mkExposedModule . convertModuleName) (exposedModules ipi), Current.hiddenModules = map convertModuleName (hiddenModules ipi), Current.instantiatedWith = [], Current.trusted = Current.trusted Current.emptyInstalledPackageInfo, Current.importDirs = importDirs ipi, Current.libraryDirs = libraryDirs ipi, Current.dataDir = "", Current.hsLibraries = hsLibraries ipi, Current.extraLibraries = extraLibraries ipi, Current.extraGHCiLibraries = extraGHCiLibraries ipi, Current.includeDirs = includeDirs ipi, Current.includes = includes ipi, Current.depends = map (mkInstalledPackageId.convertPackageId) (depends ipi), Current.ccOptions = ccOptions ipi, Current.ldOptions = ldOptions ipi, Current.frameworkDirs = frameworkDirs ipi, Current.frameworks = frameworks ipi, Current.haddockInterfaces = haddockInterfaces ipi, Current.haddockHTMLs = haddockHTMLs ipi, Current.pkgRoot = Nothing } Cabal-1.22.5.0/Distribution/Simple/PreProcess/0000755000000000000000000000000012627136220017125 5ustar0000000000000000Cabal-1.22.5.0/Distribution/Simple/PreProcess/Unlit.hs0000644000000000000000000001574412627136220020567 0ustar0000000000000000----------------------------------------------------------------------------- -- | -- Module : Distribution.Simple.PreProcess.Unlit -- Copyright : ... -- -- Maintainer : cabal-devel@haskell.org -- Portability : portable -- -- Remove the \"literal\" markups from a Haskell source file, including -- \"@>@\", \"@\\begin{code}@\", \"@\\end{code}@\", and \"@#@\" -- This version is interesting because instead of striping comment lines, it -- turns them into "-- " style comments. This allows using haddock markup -- in literate scripts without having to use "> --" prefix. module Distribution.Simple.PreProcess.Unlit (unlit,plain) where import Data.Char import Data.List data Classified = BirdTrack String | Blank String | Ordinary String | Line !Int String | CPP String | BeginCode | EndCode -- output only: | Error String | Comment String -- | No unliteration. plain :: String -> String -> String plain _ hs = hs classify :: String -> Classified classify ('>':s) = BirdTrack s classify ('#':s) = case tokens s of (line:file:_) | all isDigit line && length file >= 2 && head file == '"' && last file == '"' -> Line (read line) (tail (init file)) _ -> CPP s where tokens = unfoldr $ \str -> case lex str of (t@(_:_), str'):_ -> Just (t, str') _ -> Nothing classify ('\\':s) | "begin{code}" `isPrefixOf` s = BeginCode | "end{code}" `isPrefixOf` s = EndCode classify s | all isSpace s = Blank s classify s = Ordinary s -- So the weird exception for comment indenting is to make things work with -- haddock, see classifyAndCheckForBirdTracks below. unclassify :: Bool -> Classified -> String unclassify _ (BirdTrack s) = ' ':s unclassify _ (Blank s) = s unclassify _ (Ordinary s) = s unclassify _ (Line n file) = "# " ++ show n ++ " " ++ show file unclassify _ (CPP s) = '#':s unclassify True (Comment "") = " --" unclassify True (Comment s) = " -- " ++ s unclassify False (Comment "") = "--" unclassify False (Comment s) = "-- " ++ s unclassify _ _ = internalError -- | 'unlit' takes a filename (for error reports), and transforms the -- given string, to eliminate the literate comments from the program text. unlit :: FilePath -> String -> Either String String unlit file input = let (usesBirdTracks, classified) = classifyAndCheckForBirdTracks . inlines $ input in either (Left . unlines . map (unclassify usesBirdTracks)) Right . checkErrors . reclassify $ classified where -- So haddock requires comments and code to align, since it treats comments -- as following the layout rule. This is a pain for us since bird track -- style literate code typically gets indented by two since ">" is replaced -- by " " and people usually use one additional space of indent ie -- "> then the code". On the other hand we cannot just go and indent all -- the comments by two since that does not work for latex style literate -- code. So the hacky solution we use here is that if we see any bird track -- style code then we'll indent all comments by two, otherwise by none. -- Of course this will not work for mixed latex/bird track .lhs files but -- nobody does that, it's silly and specifically recommended against in the -- H98 unlit spec. -- classifyAndCheckForBirdTracks = flip mapAccumL False $ \seenBirdTrack line -> let classification = classify line in (seenBirdTrack || isBirdTrack classification, classification) isBirdTrack (BirdTrack _) = True isBirdTrack _ = False checkErrors ls = case [ e | Error e <- ls ] of [] -> Left ls (message:_) -> Right (f ++ ":" ++ show n ++ ": " ++ message) where (f, n) = errorPos file 1 ls errorPos f n [] = (f, n) errorPos f n (Error _:_) = (f, n) errorPos _ _ (Line n' f':ls) = errorPos f' n' ls errorPos f n (_ :ls) = errorPos f (n+1) ls -- Here we model a state machine, with each state represented by -- a local function. We only have four states (well, five, -- if you count the error state), but the rules -- to transition between then are not so simple. -- Would it be simpler to have more states? -- -- Each state represents the type of line that was last read -- i.e. are we in a comment section, or a latex-code section, -- or a bird-code section, etc? reclassify :: [Classified] -> [Classified] reclassify = blank -- begin in blank state where latex [] = [] latex (EndCode :ls) = Blank "" : comment ls latex (BeginCode :_ ) = [Error "\\begin{code} in code section"] latex (BirdTrack l:ls) = Ordinary ('>':l) : latex ls latex ( l:ls) = l : latex ls blank [] = [] blank (EndCode :_ ) = [Error "\\end{code} without \\begin{code}"] blank (BeginCode :ls) = Blank "" : latex ls blank (BirdTrack l:ls) = BirdTrack l : bird ls blank (Ordinary l:ls) = Comment l : comment ls blank ( l:ls) = l : blank ls bird [] = [] bird (EndCode :_ ) = [Error "\\end{code} without \\begin{code}"] bird (BeginCode :ls) = Blank "" : latex ls bird (Blank l :ls) = Blank l : blank ls bird (Ordinary _:_ ) = [Error "program line before comment line"] bird ( l:ls) = l : bird ls comment [] = [] comment (EndCode :_ ) = [Error "\\end{code} without \\begin{code}"] comment (BeginCode :ls) = Blank "" : latex ls comment (CPP l :ls) = CPP l : comment ls comment (BirdTrack _:_ ) = [Error "comment line before program line"] -- a blank line and another ordinary line following a comment -- will be treated as continuing the comment. Otherwise it's -- then end of the comment, with a blank line. comment (Blank l:ls@(Ordinary _:_)) = Comment l : comment ls comment (Blank l:ls) = Blank l : blank ls comment (Line n f :ls) = Line n f : comment ls comment (Ordinary l:ls) = Comment l : comment ls comment (Comment _: _) = internalError comment (Error _: _) = internalError -- Re-implementation of 'lines', for better efficiency (but decreased laziness). -- Also, importantly, accepts non-standard DOS and Mac line ending characters. inlines :: String -> [String] inlines xs = lines' xs id where lines' [] acc = [acc []] lines' ('\^M':'\n':s) acc = acc [] : lines' s id -- DOS lines' ('\^M':s) acc = acc [] : lines' s id -- MacOS lines' ('\n':s) acc = acc [] : lines' s id -- Unix lines' (c:s) acc = lines' s (acc . (c:)) internalError :: a internalError = error "unlit: internal error" Cabal-1.22.5.0/Distribution/Simple/Program/0000755000000000000000000000000012627136220016447 5ustar0000000000000000Cabal-1.22.5.0/Distribution/Simple/Program/Ar.hs0000644000000000000000000001516512627136220017355 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} ----------------------------------------------------------------------------- -- | -- Module : Distribution.Simple.Program.Ar -- Copyright : Duncan Coutts 2009 -- -- Maintainer : cabal-devel@haskell.org -- Portability : portable -- -- This module provides an library interface to the @ar@ program. module Distribution.Simple.Program.Ar ( createArLibArchive, multiStageProgramInvocation ) where import Control.Monad (when, unless) import qualified Data.ByteString as BS import qualified Data.ByteString.Char8 as BS8 import Data.Char (isSpace) import Distribution.Compat.CopyFile (filesEqual) import Distribution.Simple.LocalBuildInfo (LocalBuildInfo(..)) import Distribution.Simple.Program ( arProgram, requireProgram ) import Distribution.Simple.Program.Run ( programInvocation, multiStageProgramInvocation , runProgramInvocation ) import qualified Distribution.Simple.Program.Strip as Strip ( stripLib ) import Distribution.Simple.Utils ( dieWithLocation, withTempDirectory ) import Distribution.System ( Arch(..), OS(..), Platform(..) ) import Distribution.Verbosity ( Verbosity, deafening, verbose ) import System.Directory (doesFileExist, renameFile) import System.FilePath ((), splitFileName) import System.IO ( Handle, IOMode(ReadWriteMode), SeekMode(AbsoluteSeek) , hFileSize, hSeek, withBinaryFile ) -- | Call @ar@ to create a library archive from a bunch of object files. -- createArLibArchive :: Verbosity -> LocalBuildInfo -> FilePath -> [FilePath] -> IO () createArLibArchive verbosity lbi targetPath files = do (ar, _) <- requireProgram verbosity arProgram progConf let (targetDir, targetName) = splitFileName targetPath withTempDirectory verbosity targetDir "objs" $ \ tmpDir -> do let tmpPath = tmpDir targetName -- The args to use with "ar" are actually rather subtle and system-dependent. -- In particular we have the following issues: -- -- -- On OS X, "ar q" does not make an archive index. Archives with no -- index cannot be used. -- -- -- GNU "ar r" will not let us add duplicate objects, only "ar q" lets us -- do that. We have duplicates because of modules like "A.M" and "B.M" -- both make an object file "M.o" and ar does not consider the directory. -- -- Our solution is to use "ar r" in the simple case when one call is enough. -- When we need to call ar multiple times we use "ar q" and for the last -- call on OSX we use "ar qs" so that it'll make the index. let simpleArgs = case hostOS of OSX -> ["-r", "-s"] _ -> ["-r"] initialArgs = ["-q"] finalArgs = case hostOS of OSX -> ["-q", "-s"] _ -> ["-q"] extraArgs = verbosityOpts verbosity ++ [tmpPath] simple = programInvocation ar (simpleArgs ++ extraArgs) initial = programInvocation ar (initialArgs ++ extraArgs) middle = initial final = programInvocation ar (finalArgs ++ extraArgs) sequence_ [ runProgramInvocation verbosity inv | inv <- multiStageProgramInvocation simple (initial, middle, final) files ] when stripLib $ Strip.stripLib verbosity platform progConf tmpPath unless (hostArch == Arm) $ -- See #1537 wipeMetadata tmpPath equal <- filesEqual tmpPath targetPath unless equal $ renameFile tmpPath targetPath where progConf = withPrograms lbi stripLib = stripLibs lbi platform@(Platform hostArch hostOS) = hostPlatform lbi verbosityOpts v | v >= deafening = ["-v"] | v >= verbose = [] | otherwise = ["-c"] -- | @ar@ by default includes various metadata for each object file in their -- respective headers, so the output can differ for the same inputs, making -- it difficult to avoid re-linking. GNU @ar@(1) has a deterministic mode -- (@-D@) flag that always writes zero for the mtime, UID and GID, and 0644 -- for the file mode. However detecting whether @-D@ is supported seems -- rather harder than just re-implementing this feature. wipeMetadata :: FilePath -> IO () wipeMetadata path = do -- Check for existence first (ReadWriteMode would create one otherwise) exists <- doesFileExist path unless exists $ wipeError "Temporary file disappeared" withBinaryFile path ReadWriteMode $ \ h -> hFileSize h >>= wipeArchive h where wipeError msg = dieWithLocation path Nothing $ "Distribution.Simple.Program.Ar.wipeMetadata: " ++ msg archLF = "!\x0a" -- global magic, 8 bytes x60LF = "\x60\x0a" -- header magic, 2 bytes metadata = BS.concat [ "0 " -- mtime, 12 bytes , "0 " -- UID, 6 bytes , "0 " -- GID, 6 bytes , "0644 " -- mode, 8 bytes ] headerSize :: Int headerSize = 60 -- http://en.wikipedia.org/wiki/Ar_(Unix)#File_format_details wipeArchive :: Handle -> Integer -> IO () wipeArchive h archiveSize = do global <- BS.hGet h (BS.length archLF) unless (global == archLF) $ wipeError "Bad global header" wipeHeader (toInteger $ BS.length archLF) where wipeHeader :: Integer -> IO () wipeHeader offset = case compare offset archiveSize of EQ -> return () GT -> wipeError (atOffset "Archive truncated") LT -> do header <- BS.hGet h headerSize unless (BS.length header == headerSize) $ wipeError (atOffset "Short header") let magic = BS.drop 58 header unless (magic == x60LF) . wipeError . atOffset $ "Bad magic " ++ show magic ++ " in header" let name = BS.take 16 header let size = BS.take 10 $ BS.drop 48 header objSize <- case reads (BS8.unpack size) of [(n, s)] | all isSpace s -> return n _ -> wipeError (atOffset "Bad file size in header") let replacement = BS.concat [ name, metadata, size, magic ] unless (BS.length replacement == headerSize) $ wipeError (atOffset "Something has gone terribly wrong") hSeek h AbsoluteSeek offset BS.hPut h replacement let nextHeader = offset + toInteger headerSize + -- Odd objects are padded with an extra '\x0a' if odd objSize then objSize + 1 else objSize hSeek h AbsoluteSeek nextHeader wipeHeader nextHeader where atOffset msg = msg ++ " at offset " ++ show offset Cabal-1.22.5.0/Distribution/Simple/Program/Builtin.hs0000644000000000000000000002614212627136220020416 0ustar0000000000000000----------------------------------------------------------------------------- -- | -- Module : Distribution.Simple.Program.Builtin -- Copyright : Isaac Jones 2006, Duncan Coutts 2007-2009 -- -- Maintainer : cabal-devel@haskell.org -- Portability : portable -- -- The module defines all the known built-in 'Program's. -- -- Where possible we try to find their version numbers. -- module Distribution.Simple.Program.Builtin ( -- * The collection of unconfigured and configured programs builtinPrograms, -- * Programs that Cabal knows about ghcProgram, ghcPkgProgram, ghcjsProgram, ghcjsPkgProgram, lhcProgram, lhcPkgProgram, hmakeProgram, jhcProgram, haskellSuiteProgram, haskellSuitePkgProgram, uhcProgram, gccProgram, arProgram, stripProgram, happyProgram, alexProgram, hsc2hsProgram, c2hsProgram, cpphsProgram, hscolourProgram, haddockProgram, greencardProgram, ldProgram, tarProgram, cppProgram, pkgConfigProgram, hpcProgram, ) where import Distribution.Simple.Program.Find ( findProgramOnSearchPath ) import Distribution.Simple.Program.Run ( getProgramInvocationOutput, programInvocation ) import Distribution.Simple.Program.Types ( Program(..), ConfiguredProgram(..), simpleProgram ) import Distribution.Simple.Utils ( findProgramVersion ) import Distribution.Compat.Exception ( catchIO ) import Distribution.Verbosity ( lessVerbose ) import Distribution.Version ( Version(..), withinRange, earlierVersion, laterVersion , intersectVersionRanges ) import Data.Char ( isDigit ) import Data.List ( isInfixOf ) import qualified Data.Map as Map -- ------------------------------------------------------------ -- * Known programs -- ------------------------------------------------------------ -- | The default list of programs. -- These programs are typically used internally to Cabal. builtinPrograms :: [Program] builtinPrograms = [ -- compilers and related progs ghcProgram , ghcPkgProgram , ghcjsProgram , ghcjsPkgProgram , haskellSuiteProgram , haskellSuitePkgProgram , hmakeProgram , jhcProgram , lhcProgram , lhcPkgProgram , uhcProgram , hpcProgram -- preprocessors , hscolourProgram , haddockProgram , happyProgram , alexProgram , hsc2hsProgram , c2hsProgram , cpphsProgram , greencardProgram -- platform toolchain , gccProgram , arProgram , stripProgram , ldProgram , tarProgram -- configuration tools , pkgConfigProgram ] ghcProgram :: Program ghcProgram = (simpleProgram "ghc") { programFindVersion = findProgramVersion "--numeric-version" id, -- Workaround for https://ghc.haskell.org/trac/ghc/ticket/8825 -- (spurious warning on non-english locales) programPostConf = \_verbosity ghcProg -> do let ghcProg' = ghcProg { programOverrideEnv = ("LANGUAGE", Just "en") : programOverrideEnv ghcProg } -- Only the 7.8 branch seems to be affected. Fixed in 7.8.4. affectedVersionRange = intersectVersionRanges (laterVersion $ Version [7,8,0] []) (earlierVersion $ Version [7,8,4] []) return $ maybe ghcProg (\v -> if withinRange v affectedVersionRange then ghcProg' else ghcProg) (programVersion ghcProg) } ghcPkgProgram :: Program ghcPkgProgram = (simpleProgram "ghc-pkg") { programFindVersion = findProgramVersion "--version" $ \str -> -- Invoking "ghc-pkg --version" gives a string like -- "GHC package manager version 6.4.1" case words str of (_:_:_:_:ver:_) -> ver _ -> "" } ghcjsProgram :: Program ghcjsProgram = (simpleProgram "ghcjs") { programFindVersion = findProgramVersion "--numeric-ghcjs-version" id } -- note: version is the version number of the GHC version that ghcjs-pkg was built with ghcjsPkgProgram :: Program ghcjsPkgProgram = (simpleProgram "ghcjs-pkg") { programFindVersion = findProgramVersion "--version" $ \str -> -- Invoking "ghcjs-pkg --version" gives a string like -- "GHCJS package manager version 6.4.1" case words str of (_:_:_:_:ver:_) -> ver _ -> "" } lhcProgram :: Program lhcProgram = (simpleProgram "lhc") { programFindVersion = findProgramVersion "--numeric-version" id } lhcPkgProgram :: Program lhcPkgProgram = (simpleProgram "lhc-pkg") { programFindVersion = findProgramVersion "--version" $ \str -> -- Invoking "lhc-pkg --version" gives a string like -- "LHC package manager version 0.7" case words str of (_:_:_:_:ver:_) -> ver _ -> "" } hmakeProgram :: Program hmakeProgram = (simpleProgram "hmake") { programFindVersion = findProgramVersion "--version" $ \str -> -- Invoking "hmake --version" gives a string line -- "/usr/local/bin/hmake: 3.13 (2006-11-01)" case words str of (_:ver:_) -> ver _ -> "" } jhcProgram :: Program jhcProgram = (simpleProgram "jhc") { programFindVersion = findProgramVersion "--version" $ \str -> -- invoking "jhc --version" gives a string like -- "jhc 0.3.20080208 (wubgipkamcep-2) -- compiled by ghc-6.8 on a x86_64 running linux" case words str of (_:ver:_) -> ver _ -> "" } uhcProgram :: Program uhcProgram = (simpleProgram "uhc") { programFindVersion = findProgramVersion "--version-dotted" id } hpcProgram :: Program hpcProgram = (simpleProgram "hpc") { programFindVersion = findProgramVersion "version" $ \str -> case words str of (_ : _ : _ : ver : _) -> ver _ -> "" } -- This represents a haskell-suite compiler. Of course, the compiler -- itself probably is not called "haskell-suite", so this is not a real -- program. (But we don't know statically the name of the actual compiler, -- so this is the best we can do.) -- -- Having this Program value serves two purposes: -- -- 1. We can accept options for the compiler in the form of -- -- --haskell-suite-option(s)=... -- -- 2. We can find a program later using this static id (with -- requireProgram). -- -- The path to the real compiler is found and recorded in the ProgramDb -- during the configure phase. haskellSuiteProgram :: Program haskellSuiteProgram = (simpleProgram "haskell-suite") { -- pretend that the program exists, otherwise it won't be in the -- "configured" state programFindLocation = \_verbosity _searchPath -> return $ Just "haskell-suite-dummy-location" } -- This represent a haskell-suite package manager. See the comments for -- haskellSuiteProgram. haskellSuitePkgProgram :: Program haskellSuitePkgProgram = (simpleProgram "haskell-suite-pkg") { programFindLocation = \_verbosity _searchPath -> return $ Just "haskell-suite-pkg-dummy-location" } happyProgram :: Program happyProgram = (simpleProgram "happy") { programFindVersion = findProgramVersion "--version" $ \str -> -- Invoking "happy --version" gives a string like -- "Happy Version 1.16 Copyright (c) ...." case words str of (_:_:ver:_) -> ver _ -> "" } alexProgram :: Program alexProgram = (simpleProgram "alex") { programFindVersion = findProgramVersion "--version" $ \str -> -- Invoking "alex --version" gives a string like -- "Alex version 2.1.0, (c) 2003 Chris Dornan and Simon Marlow" case words str of (_:_:ver:_) -> takeWhile (\x -> isDigit x || x == '.') ver _ -> "" } gccProgram :: Program gccProgram = (simpleProgram "gcc") { programFindVersion = findProgramVersion "-dumpversion" id } arProgram :: Program arProgram = simpleProgram "ar" stripProgram :: Program stripProgram = (simpleProgram "strip") { programFindVersion = \verbosity -> findProgramVersion "--version" selectVersion (lessVerbose verbosity) } where selectVersion str = -- Invoking "strip --version" gives very inconsistent -- results. We look for the first word that starts with a -- number, and try parsing out the first two components of -- it. Non-GNU 'strip' doesn't appear to have a version flag. let numeric "" = False numeric (x:_) = isDigit x in case dropWhile (not . numeric) (words str) of (ver:_) -> -- take the first two version components let isDot = (== '.') (major, rest) = break isDot ver minor = takeWhile (not . isDot) (dropWhile isDot rest) in major ++ "." ++ minor _ -> "" hsc2hsProgram :: Program hsc2hsProgram = (simpleProgram "hsc2hs") { programFindVersion = findProgramVersion "--version" $ \str -> -- Invoking "hsc2hs --version" gives a string like "hsc2hs version 0.66" case words str of (_:_:ver:_) -> ver _ -> "" } c2hsProgram :: Program c2hsProgram = (simpleProgram "c2hs") { programFindVersion = findProgramVersion "--numeric-version" id } cpphsProgram :: Program cpphsProgram = (simpleProgram "cpphs") { programFindVersion = findProgramVersion "--version" $ \str -> -- Invoking "cpphs --version" gives a string like "cpphs 1.3" case words str of (_:ver:_) -> ver _ -> "" } hscolourProgram :: Program hscolourProgram = (simpleProgram "hscolour") { programFindLocation = \v p -> findProgramOnSearchPath v p "HsColour", programFindVersion = findProgramVersion "-version" $ \str -> -- Invoking "HsColour -version" gives a string like "HsColour 1.7" case words str of (_:ver:_) -> ver _ -> "" } haddockProgram :: Program haddockProgram = (simpleProgram "haddock") { programFindVersion = findProgramVersion "--version" $ \str -> -- Invoking "haddock --version" gives a string like -- "Haddock version 0.8, (c) Simon Marlow 2006" case words str of (_:_:ver:_) -> takeWhile (`elem` ('.':['0'..'9'])) ver _ -> "" } greencardProgram :: Program greencardProgram = simpleProgram "greencard" ldProgram :: Program ldProgram = simpleProgram "ld" tarProgram :: Program tarProgram = (simpleProgram "tar") { -- See #1901. Some versions of 'tar' (OpenBSD, NetBSD, ...) don't support the -- '--format' option. programPostConf = \verbosity tarProg -> do tarHelpOutput <- getProgramInvocationOutput verbosity (programInvocation tarProg ["--help"]) -- Some versions of tar don't support '--help'. `catchIO` (\_ -> return "") let k = "Supports --format" v = if ("--format" `isInfixOf` tarHelpOutput) then "YES" else "NO" m = Map.insert k v (programProperties tarProg) return $ tarProg { programProperties = m } } cppProgram :: Program cppProgram = simpleProgram "cpp" pkgConfigProgram :: Program pkgConfigProgram = (simpleProgram "pkg-config") { programFindVersion = findProgramVersion "--version" id } Cabal-1.22.5.0/Distribution/Simple/Program/Db.hs0000644000000000000000000004265212627136220017341 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveGeneric #-} ----------------------------------------------------------------------------- -- | -- Module : Distribution.Simple.Program.Db -- Copyright : Isaac Jones 2006, Duncan Coutts 2007-2009 -- -- Maintainer : cabal-devel@haskell.org -- Portability : portable -- -- This provides a 'ProgramDb' type which holds configured and not-yet -- configured programs. It is the parameter to lots of actions elsewhere in -- Cabal that need to look up and run programs. If we had a Cabal monad, -- the 'ProgramDb' would probably be a reader or state component of it. -- -- One nice thing about using it is that any program that is -- registered with Cabal will get some \"configure\" and \".cabal\" -- helpers like --with-foo-args --foo-path= and extra-foo-args. -- -- There's also a hook for adding programs in a Setup.lhs script. See -- hookedPrograms in 'Distribution.Simple.UserHooks'. This gives a -- hook user the ability to get the above flags and such so that they -- don't have to write all the PATH logic inside Setup.lhs. module Distribution.Simple.Program.Db ( -- * The collection of configured programs we can run ProgramDb, emptyProgramDb, defaultProgramDb, restoreProgramDb, -- ** Query and manipulate the program db addKnownProgram, addKnownPrograms, lookupKnownProgram, knownPrograms, getProgramSearchPath, setProgramSearchPath, modifyProgramSearchPath, userSpecifyPath, userSpecifyPaths, userMaybeSpecifyPath, userSpecifyArgs, userSpecifyArgss, userSpecifiedArgs, lookupProgram, updateProgram, configuredPrograms, -- ** Query and manipulate the program db configureProgram, configureAllKnownPrograms, lookupProgramVersion, reconfigurePrograms, requireProgram, requireProgramVersion, ) where import Distribution.Simple.Program.Types ( Program(..), ProgArg, ConfiguredProgram(..), ProgramLocation(..) ) import Distribution.Simple.Program.Find ( ProgramSearchPath, defaultProgramSearchPath , findProgramOnSearchPath, programSearchPathAsPATHVar ) import Distribution.Simple.Program.Builtin ( builtinPrograms ) import Distribution.Simple.Utils ( die, doesExecutableExist ) import Distribution.Version ( Version, VersionRange, isAnyVersion, withinRange ) import Distribution.Text ( display ) import Distribution.Verbosity ( Verbosity ) import Distribution.Compat.Binary (Binary(..)) #if __GLASGOW_HASKELL__ < 710 import Data.Functor ((<$>)) #endif import Data.List ( foldl' ) import Data.Maybe ( catMaybes ) import qualified Data.Map as Map import Control.Monad ( join, foldM ) -- ------------------------------------------------------------ -- * Programs database -- ------------------------------------------------------------ -- | The configuration is a collection of information about programs. It -- contains information both about configured programs and also about programs -- that we are yet to configure. -- -- The idea is that we start from a collection of unconfigured programs and one -- by one we try to configure them at which point we move them into the -- configured collection. For unconfigured programs we record not just the -- 'Program' but also any user-provided arguments and location for the program. data ProgramDb = ProgramDb { unconfiguredProgs :: UnconfiguredProgs, progSearchPath :: ProgramSearchPath, configuredProgs :: ConfiguredProgs } type UnconfiguredProgram = (Program, Maybe FilePath, [ProgArg]) type UnconfiguredProgs = Map.Map String UnconfiguredProgram type ConfiguredProgs = Map.Map String ConfiguredProgram emptyProgramDb :: ProgramDb emptyProgramDb = ProgramDb Map.empty defaultProgramSearchPath Map.empty defaultProgramDb :: ProgramDb defaultProgramDb = restoreProgramDb builtinPrograms emptyProgramDb -- internal helpers: updateUnconfiguredProgs :: (UnconfiguredProgs -> UnconfiguredProgs) -> ProgramDb -> ProgramDb updateUnconfiguredProgs update conf = conf { unconfiguredProgs = update (unconfiguredProgs conf) } updateConfiguredProgs :: (ConfiguredProgs -> ConfiguredProgs) -> ProgramDb -> ProgramDb updateConfiguredProgs update conf = conf { configuredProgs = update (configuredProgs conf) } -- Read & Show instances are based on listToFM -- Note that we only serialise the configured part of the database, this is -- because we don't need the unconfigured part after the configure stage, and -- additionally because we cannot read/show 'Program' as it contains functions. instance Show ProgramDb where show = show . Map.toAscList . configuredProgs instance Read ProgramDb where readsPrec p s = [ (emptyProgramDb { configuredProgs = Map.fromList s' }, r) | (s', r) <- readsPrec p s ] instance Binary ProgramDb where put = put . configuredProgs get = do progs <- get return $! emptyProgramDb { configuredProgs = progs } -- | The Read\/Show instance does not preserve all the unconfigured 'Programs' -- because 'Program' is not in Read\/Show because it contains functions. So to -- fully restore a deserialised 'ProgramDb' use this function to add -- back all the known 'Program's. -- -- * It does not add the default programs, but you probably want them, use -- 'builtinPrograms' in addition to any extra you might need. -- restoreProgramDb :: [Program] -> ProgramDb -> ProgramDb restoreProgramDb = addKnownPrograms -- ------------------------------- -- Managing unconfigured programs -- | Add a known program that we may configure later -- addKnownProgram :: Program -> ProgramDb -> ProgramDb addKnownProgram prog = updateUnconfiguredProgs $ Map.insertWith combine (programName prog) (prog, Nothing, []) where combine _ (_, path, args) = (prog, path, args) addKnownPrograms :: [Program] -> ProgramDb -> ProgramDb addKnownPrograms progs conf = foldl' (flip addKnownProgram) conf progs lookupKnownProgram :: String -> ProgramDb -> Maybe Program lookupKnownProgram name = fmap (\(p,_,_)->p) . Map.lookup name . unconfiguredProgs knownPrograms :: ProgramDb -> [(Program, Maybe ConfiguredProgram)] knownPrograms conf = [ (p,p') | (p,_,_) <- Map.elems (unconfiguredProgs conf) , let p' = Map.lookup (programName p) (configuredProgs conf) ] -- | Get the current 'ProgramSearchPath' used by the 'ProgramDb'. -- This is the default list of locations where programs are looked for when -- configuring them. This can be overridden for specific programs (with -- 'userSpecifyPath'), and specific known programs can modify or ignore this -- search path in their own configuration code. -- getProgramSearchPath :: ProgramDb -> ProgramSearchPath getProgramSearchPath = progSearchPath -- | Change the current 'ProgramSearchPath' used by the 'ProgramDb'. -- This will affect programs that are configured from here on, so you -- should usually set it before configuring any programs. -- setProgramSearchPath :: ProgramSearchPath -> ProgramDb -> ProgramDb setProgramSearchPath searchpath db = db { progSearchPath = searchpath } -- | Modify the current 'ProgramSearchPath' used by the 'ProgramDb'. -- This will affect programs that are configured from here on, so you -- should usually modify it before configuring any programs. -- modifyProgramSearchPath :: (ProgramSearchPath -> ProgramSearchPath) -> ProgramDb -> ProgramDb modifyProgramSearchPath f db = setProgramSearchPath (f $ getProgramSearchPath db) db -- |User-specify this path. Basically override any path information -- for this program in the configuration. If it's not a known -- program ignore it. -- userSpecifyPath :: String -- ^Program name -> FilePath -- ^user-specified path to the program -> ProgramDb -> ProgramDb userSpecifyPath name path = updateUnconfiguredProgs $ flip Map.update name $ \(prog, _, args) -> Just (prog, Just path, args) userMaybeSpecifyPath :: String -> Maybe FilePath -> ProgramDb -> ProgramDb userMaybeSpecifyPath _ Nothing conf = conf userMaybeSpecifyPath name (Just path) conf = userSpecifyPath name path conf -- |User-specify the arguments for this program. Basically override -- any args information for this program in the configuration. If it's -- not a known program, ignore it.. userSpecifyArgs :: String -- ^Program name -> [ProgArg] -- ^user-specified args -> ProgramDb -> ProgramDb userSpecifyArgs name args' = updateUnconfiguredProgs (flip Map.update name $ \(prog, path, args) -> Just (prog, path, args ++ args')) . updateConfiguredProgs (flip Map.update name $ \prog -> Just prog { programOverrideArgs = programOverrideArgs prog ++ args' }) -- | Like 'userSpecifyPath' but for a list of progs and their paths. -- userSpecifyPaths :: [(String, FilePath)] -> ProgramDb -> ProgramDb userSpecifyPaths paths conf = foldl' (\conf' (prog, path) -> userSpecifyPath prog path conf') conf paths -- | Like 'userSpecifyPath' but for a list of progs and their args. -- userSpecifyArgss :: [(String, [ProgArg])] -> ProgramDb -> ProgramDb userSpecifyArgss argss conf = foldl' (\conf' (prog, args) -> userSpecifyArgs prog args conf') conf argss -- | Get the path that has been previously specified for a program, if any. -- userSpecifiedPath :: Program -> ProgramDb -> Maybe FilePath userSpecifiedPath prog = join . fmap (\(_,p,_)->p) . Map.lookup (programName prog) . unconfiguredProgs -- | Get any extra args that have been previously specified for a program. -- userSpecifiedArgs :: Program -> ProgramDb -> [ProgArg] userSpecifiedArgs prog = maybe [] (\(_,_,as)->as) . Map.lookup (programName prog) . unconfiguredProgs -- ----------------------------- -- Managing configured programs -- | Try to find a configured program lookupProgram :: Program -> ProgramDb -> Maybe ConfiguredProgram lookupProgram prog = Map.lookup (programName prog) . configuredProgs -- | Update a configured program in the database. updateProgram :: ConfiguredProgram -> ProgramDb -> ProgramDb updateProgram prog = updateConfiguredProgs $ Map.insert (programId prog) prog -- | List all configured programs. configuredPrograms :: ProgramDb -> [ConfiguredProgram] configuredPrograms = Map.elems . configuredProgs -- --------------------------- -- Configuring known programs -- | Try to configure a specific program. If the program is already included in -- the collection of unconfigured programs then we use any user-supplied -- location and arguments. If the program gets configured successfully it gets -- added to the configured collection. -- -- Note that it is not a failure if the program cannot be configured. It's only -- a failure if the user supplied a location and the program could not be found -- at that location. -- -- The reason for it not being a failure at this stage is that we don't know up -- front all the programs we will need, so we try to configure them all. -- To verify that a program was actually successfully configured use -- 'requireProgram'. -- configureProgram :: Verbosity -> Program -> ProgramDb -> IO ProgramDb configureProgram verbosity prog conf = do let name = programName prog maybeLocation <- case userSpecifiedPath prog conf of Nothing -> programFindLocation prog verbosity (progSearchPath conf) >>= return . fmap FoundOnSystem Just path -> do absolute <- doesExecutableExist path if absolute then return (Just (UserSpecified path)) else findProgramOnSearchPath verbosity (progSearchPath conf) path >>= maybe (die notFound) (return . Just . UserSpecified) where notFound = "Cannot find the program '" ++ name ++ "'. User-specified path '" ++ path ++ "' does not refer to an executable and " ++ "the program is not on the system path." case maybeLocation of Nothing -> return conf Just location -> do version <- programFindVersion prog verbosity (locationPath location) newPath <- programSearchPathAsPATHVar (progSearchPath conf) let configuredProg = ConfiguredProgram { programId = name, programVersion = version, programDefaultArgs = [], programOverrideArgs = userSpecifiedArgs prog conf, programOverrideEnv = [("PATH", Just newPath)], programProperties = Map.empty, programLocation = location } configuredProg' <- programPostConf prog verbosity configuredProg return (updateConfiguredProgs (Map.insert name configuredProg') conf) -- | Configure a bunch of programs using 'configureProgram'. Just a 'foldM'. -- configurePrograms :: Verbosity -> [Program] -> ProgramDb -> IO ProgramDb configurePrograms verbosity progs conf = foldM (flip (configureProgram verbosity)) conf progs -- | Try to configure all the known programs that have not yet been configured. -- configureAllKnownPrograms :: Verbosity -> ProgramDb -> IO ProgramDb configureAllKnownPrograms verbosity conf = configurePrograms verbosity [ prog | (prog,_,_) <- Map.elems notYetConfigured ] conf where notYetConfigured = unconfiguredProgs conf `Map.difference` configuredProgs conf -- | reconfigure a bunch of programs given new user-specified args. It takes -- the same inputs as 'userSpecifyPath' and 'userSpecifyArgs' and for all progs -- with a new path it calls 'configureProgram'. -- reconfigurePrograms :: Verbosity -> [(String, FilePath)] -> [(String, [ProgArg])] -> ProgramDb -> IO ProgramDb reconfigurePrograms verbosity paths argss conf = do configurePrograms verbosity progs . userSpecifyPaths paths . userSpecifyArgss argss $ conf where progs = catMaybes [ lookupKnownProgram name conf | (name,_) <- paths ] -- | Check that a program is configured and available to be run. -- -- It raises an exception if the program could not be configured, otherwise -- it returns the configured program. -- requireProgram :: Verbosity -> Program -> ProgramDb -> IO (ConfiguredProgram, ProgramDb) requireProgram verbosity prog conf = do -- If it's not already been configured, try to configure it now conf' <- case lookupProgram prog conf of Nothing -> configureProgram verbosity prog conf Just _ -> return conf case lookupProgram prog conf' of Nothing -> die notFound Just configuredProg -> return (configuredProg, conf') where notFound = "The program '" ++ programName prog ++ "' is required but it could not be found." -- | Check that a program is configured and available to be run. -- -- Additionally check that the program version number is suitable and return -- it. For example you could require 'AnyVersion' or @'orLaterVersion' -- ('Version' [1,0] [])@ -- -- It returns the configured program, its version number and a possibly updated -- 'ProgramDb'. If the program could not be configured or the version is -- unsuitable, it returns an error value. -- lookupProgramVersion :: Verbosity -> Program -> VersionRange -> ProgramDb -> IO (Either String (ConfiguredProgram, Version, ProgramDb)) lookupProgramVersion verbosity prog range programDb = do -- If it's not already been configured, try to configure it now programDb' <- case lookupProgram prog programDb of Nothing -> configureProgram verbosity prog programDb Just _ -> return programDb case lookupProgram prog programDb' of Nothing -> return $! Left notFound Just configuredProg@ConfiguredProgram { programLocation = location } -> case programVersion configuredProg of Just version | withinRange version range -> return $! Right (configuredProg, version ,programDb') | otherwise -> return $! Left (badVersion version location) Nothing -> return $! Left (noVersion location) where notFound = "The program '" ++ programName prog ++ "'" ++ versionRequirement ++ " is required but it could not be found." badVersion v l = "The program '" ++ programName prog ++ "'" ++ versionRequirement ++ " is required but the version found at " ++ locationPath l ++ " is version " ++ display v noVersion l = "The program '" ++ programName prog ++ "'" ++ versionRequirement ++ " is required but the version of " ++ locationPath l ++ " could not be determined." versionRequirement | isAnyVersion range = "" | otherwise = " version " ++ display range -- | Like 'lookupProgramVersion', but raises an exception in case of error -- instead of returning 'Left errMsg'. -- requireProgramVersion :: Verbosity -> Program -> VersionRange -> ProgramDb -> IO (ConfiguredProgram, Version, ProgramDb) requireProgramVersion verbosity prog range programDb = join $ either die return <$> lookupProgramVersion verbosity prog range programDb Cabal-1.22.5.0/Distribution/Simple/Program/Find.hs0000644000000000000000000001140612627136220017665 0ustar0000000000000000----------------------------------------------------------------------------- -- | -- Module : Distribution.Simple.Program.Types -- Copyright : Duncan Coutts 2013 -- -- Maintainer : cabal-devel@haskell.org -- Portability : portable -- -- A somewhat extended notion of the normal program search path concept. -- -- Usually when finding executables we just want to look in the usual places -- using the OS's usual method for doing so. In Haskell the normal OS-specific -- method is captured by 'findExecutable'. On all common OSs that makes use of -- a @PATH@ environment variable, (though on Windows it is not just the @PATH@). -- -- However it is sometimes useful to be able to look in additional locations -- without having to change the process-global @PATH@ environment variable. -- So we need an extension of the usual 'findExecutable' that can look in -- additional locations, either before, after or instead of the normal OS -- locations. -- module Distribution.Simple.Program.Find ( -- * Program search path ProgramSearchPath, ProgramSearchPathEntry(..), defaultProgramSearchPath, findProgramOnSearchPath, programSearchPathAsPATHVar, ) where import Distribution.Verbosity ( Verbosity ) import Distribution.Simple.Utils ( debug, doesExecutableExist ) import Distribution.System ( OS(..), buildOS ) import System.Directory ( findExecutable ) import Distribution.Compat.Environment ( getEnvironment ) import System.FilePath ( (), (<.>), splitSearchPath, searchPathSeparator ) import Data.List ( intercalate ) -- | A search path to use when locating executables. This is analogous -- to the unix @$PATH@ or win32 @%PATH%@ but with the ability to use -- the system default method for finding executables ('findExecutable' which -- on unix is simply looking on the @$PATH@ but on win32 is a bit more -- complicated). -- -- The default to use is @[ProgSearchPathDefault]@ but you can add extra dirs -- either before, after or instead of the default, e.g. here we add an extra -- dir to search after the usual ones. -- -- > ['ProgramSearchPathDefault', 'ProgramSearchPathDir' dir] -- type ProgramSearchPath = [ProgramSearchPathEntry] data ProgramSearchPathEntry = ProgramSearchPathDir FilePath -- ^ A specific dir | ProgramSearchPathDefault -- ^ The system default defaultProgramSearchPath :: ProgramSearchPath defaultProgramSearchPath = [ProgramSearchPathDefault] findProgramOnSearchPath :: Verbosity -> ProgramSearchPath -> FilePath -> IO (Maybe FilePath) findProgramOnSearchPath verbosity searchpath prog = do debug verbosity $ "Searching for " ++ prog ++ " in path." res <- tryPathElems searchpath case res of Nothing -> debug verbosity ("Cannot find " ++ prog ++ " on the path") Just path -> debug verbosity ("Found " ++ prog ++ " at "++ path) return res where tryPathElems [] = return Nothing tryPathElems (pe:pes) = do res <- tryPathElem pe case res of Nothing -> tryPathElems pes Just _ -> return res tryPathElem (ProgramSearchPathDir dir) = findFirstExe [ dir prog <.> ext | ext <- extensions ] where -- Possible improvement: on Windows, read the list of extensions from -- the PATHEXT environment variable. By default PATHEXT is ".com; .exe; -- .bat; .cmd". extensions = case buildOS of Windows -> ["", "exe"] Ghcjs -> ["", "exe"] _ -> [""] tryPathElem ProgramSearchPathDefault = do -- 'findExecutable' doesn't check that the path really refers to an -- executable on Windows (at least with GHC < 7.8). See -- https://ghc.haskell.org/trac/ghc/ticket/2184 mExe <- findExecutable prog case mExe of Just exe -> do exeExists <- doesExecutableExist exe if exeExists then return mExe else return Nothing _ -> return mExe findFirstExe [] = return Nothing findFirstExe (f:fs) = do isExe <- doesExecutableExist f if isExe then return (Just f) else findFirstExe fs -- | Interpret a 'ProgramSearchPath' to construct a new @$PATH@ env var. -- Note that this is close but not perfect because on Windows the search -- algorithm looks at more than just the @%PATH%@. programSearchPathAsPATHVar :: ProgramSearchPath -> IO String programSearchPathAsPATHVar searchpath = do ess <- mapM getEntries searchpath return (intercalate [searchPathSeparator] (concat ess)) where getEntries (ProgramSearchPathDir dir) = return [dir] getEntries ProgramSearchPathDefault = do env <- getEnvironment return (maybe [] splitSearchPath (lookup "PATH" env)) Cabal-1.22.5.0/Distribution/Simple/Program/GHC.hs0000644000000000000000000004707112627136220017415 0ustar0000000000000000{-# LANGUAGE CPP #-} module Distribution.Simple.Program.GHC ( GhcOptions(..), GhcMode(..), GhcOptimisation(..), GhcDynLinkMode(..), ghcInvocation, renderGhcOptions, runGHC, ) where import Distribution.Simple.GHC.ImplInfo ( getImplInfo, GhcImplInfo(..) ) import Distribution.Package import Distribution.PackageDescription hiding (Flag) import Distribution.ModuleName import Distribution.Simple.Compiler hiding (Flag) import Distribution.Simple.Setup ( Flag(..), flagToMaybe, fromFlagOrDefault, flagToList ) import Distribution.Simple.Program.Types import Distribution.Simple.Program.Run import Distribution.Text import Distribution.Verbosity import Distribution.Utils.NubList ( NubListR, fromNubListR ) import Language.Haskell.Extension ( Language(..), Extension(..) ) import qualified Data.Map as M #if __GLASGOW_HASKELL__ < 710 import Data.Monoid #endif import Data.List ( intercalate ) -- | A structured set of GHC options/flags -- data GhcOptions = GhcOptions { -- | The major mode for the ghc invocation. ghcOptMode :: Flag GhcMode, -- | Any extra options to pass directly to ghc. These go at the end and hence -- override other stuff. ghcOptExtra :: NubListR String, -- | Extra default flags to pass directly to ghc. These go at the beginning -- and so can be overridden by other stuff. ghcOptExtraDefault :: NubListR String, ----------------------- -- Inputs and outputs -- | The main input files; could be .hs, .hi, .c, .o, depending on mode. ghcOptInputFiles :: NubListR FilePath, -- | The names of input Haskell modules, mainly for @--make@ mode. ghcOptInputModules :: NubListR ModuleName, -- | Location for output file; the @ghc -o@ flag. ghcOptOutputFile :: Flag FilePath, -- | Location for dynamic output file in 'GhcStaticAndDynamic' mode; -- the @ghc -dyno@ flag. ghcOptOutputDynFile :: Flag FilePath, -- | Start with an empty search path for Haskell source files; -- the @ghc -i@ flag (@-i@ on it's own with no path argument). ghcOptSourcePathClear :: Flag Bool, -- | Search path for Haskell source files; the @ghc -i@ flag. ghcOptSourcePath :: NubListR FilePath, ------------- -- Packages -- | The package key the modules will belong to; the @ghc -this-package-key@ -- flag. ghcOptPackageKey :: Flag PackageKey, -- | GHC package databases to use, the @ghc -package-conf@ flag. ghcOptPackageDBs :: PackageDBStack, -- | The GHC packages to use. For compatability with old and new ghc, this -- requires both the short and long form of the package id; -- the @ghc -package@ or @ghc -package-id@ flags. ghcOptPackages :: NubListR (InstalledPackageId, PackageId, ModuleRenaming), -- | Start with a clean package set; the @ghc -hide-all-packages@ flag ghcOptHideAllPackages :: Flag Bool, -- | Don't automatically link in Haskell98 etc; the @ghc -- -no-auto-link-packages@ flag. ghcOptNoAutoLinkPackages :: Flag Bool, -- | What packages are implementing the signatures ghcOptSigOf :: [(ModuleName, (PackageKey, ModuleName))], ----------------- -- Linker stuff -- | Names of libraries to link in; the @ghc -l@ flag. ghcOptLinkLibs :: NubListR FilePath, -- | Search path for libraries to link in; the @ghc -L@ flag. ghcOptLinkLibPath :: NubListR FilePath, -- | Options to pass through to the linker; the @ghc -optl@ flag. ghcOptLinkOptions :: NubListR String, -- | OSX only: frameworks to link in; the @ghc -framework@ flag. ghcOptLinkFrameworks :: NubListR String, -- | Don't do the link step, useful in make mode; the @ghc -no-link@ flag. ghcOptNoLink :: Flag Bool, -- | Don't link in the normal RTS @main@ entry point; the @ghc -no-hs-main@ -- flag. ghcOptLinkNoHsMain :: Flag Bool, -------------------- -- C and CPP stuff -- | Options to pass through to the C compiler; the @ghc -optc@ flag. ghcOptCcOptions :: NubListR String, -- | Options to pass through to CPP; the @ghc -optP@ flag. ghcOptCppOptions :: NubListR String, -- | Search path for CPP includes like header files; the @ghc -I@ flag. ghcOptCppIncludePath :: NubListR FilePath, -- | Extra header files to include at CPP stage; the @ghc -optP-include@ flag. ghcOptCppIncludes :: NubListR FilePath, -- | Extra header files to include for old-style FFI; the @ghc -#include@ flag. ghcOptFfiIncludes :: NubListR FilePath, ---------------------------- -- Language and extensions -- | The base language; the @ghc -XHaskell98@ or @-XHaskell2010@ flag. ghcOptLanguage :: Flag Language, -- | The language extensions; the @ghc -X@ flag. ghcOptExtensions :: NubListR Extension, -- | A GHC version-dependent mapping of extensions to flags. This must be -- set to be able to make use of the 'ghcOptExtensions'. ghcOptExtensionMap :: M.Map Extension String, ---------------- -- Compilation -- | What optimisation level to use; the @ghc -O@ flag. ghcOptOptimisation :: Flag GhcOptimisation, -- | Emit debug info; the @ghc -g@ flag. ghcOptDebugInfo :: Flag Bool, -- | Compile in profiling mode; the @ghc -prof@ flag. ghcOptProfilingMode :: Flag Bool, -- | Use the \"split object files\" feature; the @ghc -split-objs@ flag. ghcOptSplitObjs :: Flag Bool, -- | Run N jobs simultaneously (if possible). ghcOptNumJobs :: Flag (Maybe Int), -- | Enable coverage analysis; the @ghc -fhpc -hpcdir@ flags. ghcOptHPCDir :: Flag FilePath, ---------------- -- GHCi -- | Extra GHCi startup scripts; the @-ghci-script@ flag ghcOptGHCiScripts :: NubListR FilePath, ------------------------ -- Redirecting outputs ghcOptHiSuffix :: Flag String, ghcOptObjSuffix :: Flag String, ghcOptDynHiSuffix :: Flag String, -- ^ only in 'GhcStaticAndDynamic' mode ghcOptDynObjSuffix :: Flag String, -- ^ only in 'GhcStaticAndDynamic' mode ghcOptHiDir :: Flag FilePath, ghcOptObjDir :: Flag FilePath, ghcOptOutputDir :: Flag FilePath, ghcOptStubDir :: Flag FilePath, -------------------- -- Dynamic linking ghcOptDynLinkMode :: Flag GhcDynLinkMode, ghcOptShared :: Flag Bool, ghcOptFPic :: Flag Bool, ghcOptDylibName :: Flag String, ghcOptRPaths :: NubListR FilePath, --------------- -- Misc flags -- | Get GHC to be quiet or verbose with what it's doing; the @ghc -v@ flag. ghcOptVerbosity :: Flag Verbosity, -- | Let GHC know that it is Cabal that's calling it. -- Modifies some of the GHC error messages. ghcOptCabal :: Flag Bool } deriving Show data GhcMode = GhcModeCompile -- ^ @ghc -c@ | GhcModeLink -- ^ @ghc@ | GhcModeMake -- ^ @ghc --make@ | GhcModeInteractive -- ^ @ghci@ \/ @ghc --interactive@ | GhcModeAbiHash -- ^ @ghc --abi-hash@ -- | GhcModeDepAnalysis -- ^ @ghc -M@ -- | GhcModeEvaluate -- ^ @ghc -e@ deriving (Show, Eq) data GhcOptimisation = GhcNoOptimisation -- ^ @-O0@ | GhcNormalOptimisation -- ^ @-O@ | GhcMaximumOptimisation -- ^ @-O2@ | GhcSpecialOptimisation String -- ^ e.g. @-Odph@ deriving (Show, Eq) data GhcDynLinkMode = GhcStaticOnly -- ^ @-static@ | GhcDynamicOnly -- ^ @-dynamic@ | GhcStaticAndDynamic -- ^ @-static -dynamic-too@ deriving (Show, Eq) runGHC :: Verbosity -> ConfiguredProgram -> Compiler -> GhcOptions -> IO () runGHC verbosity ghcProg comp opts = do runProgramInvocation verbosity (ghcInvocation ghcProg comp opts) ghcInvocation :: ConfiguredProgram -> Compiler -> GhcOptions -> ProgramInvocation ghcInvocation prog comp opts = programInvocation prog (renderGhcOptions comp opts) renderGhcOptions :: Compiler -> GhcOptions -> [String] renderGhcOptions comp opts | compilerFlavor comp `notElem` [GHC, GHCJS] = error $ "Distribution.Simple.Program.GHC.renderGhcOptions: " ++ "compiler flavor must be 'GHC' or 'GHCJS'!" | otherwise = concat [ case flagToMaybe (ghcOptMode opts) of Nothing -> [] Just GhcModeCompile -> ["-c"] Just GhcModeLink -> [] Just GhcModeMake -> ["--make"] Just GhcModeInteractive -> ["--interactive"] Just GhcModeAbiHash -> ["--abi-hash"] -- Just GhcModeDepAnalysis -> ["-M"] -- Just GhcModeEvaluate -> ["-e", expr] , flags ghcOptExtraDefault , [ "-no-link" | flagBool ghcOptNoLink ] --------------- -- Misc flags , maybe [] verbosityOpts (flagToMaybe (ghcOptVerbosity opts)) , [ "-fbuilding-cabal-package" | flagBool ghcOptCabal , flagBuildingCabalPkg implInfo ] ---------------- -- Compilation , case flagToMaybe (ghcOptOptimisation opts) of Nothing -> [] Just GhcNoOptimisation -> ["-O0"] Just GhcNormalOptimisation -> ["-O"] Just GhcMaximumOptimisation -> ["-O2"] Just (GhcSpecialOptimisation s) -> ["-O" ++ s] -- eg -Odph , [ "-g" | flagDebugInfo implInfo && flagBool ghcOptDebugInfo ] , [ "-prof" | flagBool ghcOptProfilingMode ] , [ "-split-objs" | flagBool ghcOptSplitObjs ] , case flagToMaybe (ghcOptHPCDir opts) of Nothing -> [] Just hpcdir -> ["-fhpc", "-hpcdir", hpcdir] , if parmakeSupported comp then case ghcOptNumJobs opts of NoFlag -> [] Flag n -> ["-j" ++ maybe "" show n] else [] -------------------- -- Dynamic linking , [ "-shared" | flagBool ghcOptShared ] , case flagToMaybe (ghcOptDynLinkMode opts) of Nothing -> [] Just GhcStaticOnly -> ["-static"] Just GhcDynamicOnly -> ["-dynamic"] Just GhcStaticAndDynamic -> ["-static", "-dynamic-too"] , [ "-fPIC" | flagBool ghcOptFPic ] , concat [ ["-dylib-install-name", libname] | libname <- flag ghcOptDylibName ] ------------------------ -- Redirecting outputs , concat [ ["-osuf", suf] | suf <- flag ghcOptObjSuffix ] , concat [ ["-hisuf", suf] | suf <- flag ghcOptHiSuffix ] , concat [ ["-dynosuf", suf] | suf <- flag ghcOptDynObjSuffix ] , concat [ ["-dynhisuf",suf] | suf <- flag ghcOptDynHiSuffix ] , concat [ ["-outputdir", dir] | dir <- flag ghcOptOutputDir , flagOutputDir implInfo ] , concat [ ["-odir", dir] | dir <- flag ghcOptObjDir ] , concat [ ["-hidir", dir] | dir <- flag ghcOptHiDir ] , concat [ ["-stubdir", dir] | dir <- flag ghcOptStubDir , flagStubdir implInfo ] ----------------------- -- Source search path , [ "-i" | flagBool ghcOptSourcePathClear ] , [ "-i" ++ dir | dir <- flags ghcOptSourcePath ] -------------------- -- C and CPP stuff , [ "-I" ++ dir | dir <- flags ghcOptCppIncludePath ] , [ "-optP" ++ opt | opt <- flags ghcOptCppOptions ] , concat [ [ "-optP-include", "-optP" ++ inc] | inc <- flags ghcOptCppIncludes ] , [ "-#include \"" ++ inc ++ "\"" | inc <- flags ghcOptFfiIncludes, flagFfiIncludes implInfo ] , [ "-optc" ++ opt | opt <- flags ghcOptCcOptions ] ----------------- -- Linker stuff , [ "-optl" ++ opt | opt <- flags ghcOptLinkOptions ] , ["-l" ++ lib | lib <- flags ghcOptLinkLibs ] , ["-L" ++ dir | dir <- flags ghcOptLinkLibPath ] , concat [ ["-framework", fmwk] | fmwk <- flags ghcOptLinkFrameworks ] , [ "-no-hs-main" | flagBool ghcOptLinkNoHsMain ] , [ "-dynload deploy" | not (null (flags ghcOptRPaths)) ] , concat [ [ "-optl-Wl,-rpath," ++ dir] | dir <- flags ghcOptRPaths ] ------------- -- Packages , concat [ [if packageKeySupported comp then "-this-package-key" else "-package-name", display pkgid] | pkgid <- flag ghcOptPackageKey ] , [ "-hide-all-packages" | flagBool ghcOptHideAllPackages ] , [ "-no-auto-link-packages" | flagBool ghcOptNoAutoLinkPackages ] , packageDbArgs implInfo (ghcOptPackageDBs opts) , if null (ghcOptSigOf opts) then [] else "-sig-of" : intercalate "," (map (\(n,(p,m)) -> display n ++ " is " ++ display p ++ ":" ++ display m) (ghcOptSigOf opts)) : [] , concat $ if flagPackageId implInfo then let space "" = "" space xs = ' ' : xs in [ ["-package-id", display ipkgid ++ space (display rns)] | (ipkgid,_,rns) <- flags ghcOptPackages ] else [ ["-package", display pkgid] | (_,pkgid,_) <- flags ghcOptPackages ] ---------------------------- -- Language and extensions , if supportsHaskell2010 implInfo then [ "-X" ++ display lang | lang <- flag ghcOptLanguage ] else [] , [ case M.lookup ext (ghcOptExtensionMap opts) of Just arg -> arg Nothing -> error $ "Distribution.Simple.Program.GHC.renderGhcOptions: " ++ display ext ++ " not present in ghcOptExtensionMap." | ext <- flags ghcOptExtensions ] ---------------- -- GHCi , concat [ [ "-ghci-script", script ] | script <- flags ghcOptGHCiScripts , flagGhciScript implInfo ] --------------- -- Inputs , [ display modu | modu <- flags ghcOptInputModules ] , flags ghcOptInputFiles , concat [ [ "-o", out] | out <- flag ghcOptOutputFile ] , concat [ [ "-dyno", out] | out <- flag ghcOptOutputDynFile ] --------------- -- Extra , flags ghcOptExtra ] where implInfo = getImplInfo comp flag flg = flagToList (flg opts) flags flg = fromNubListR . flg $ opts flagBool flg = fromFlagOrDefault False (flg opts) verbosityOpts :: Verbosity -> [String] verbosityOpts verbosity | verbosity >= deafening = ["-v"] | verbosity >= normal = [] | otherwise = ["-w", "-v0"] packageDbArgs :: GhcImplInfo -> PackageDBStack -> [String] packageDbArgs implInfo dbstack = case dbstack of (GlobalPackageDB:UserPackageDB:dbs) -> concatMap specific dbs (GlobalPackageDB:dbs) -> ("-no-user-" ++ packageDbFlag) : concatMap specific dbs _ -> ierror where specific (SpecificPackageDB db) = [ '-':packageDbFlag , db ] specific _ = ierror ierror = error $ "internal error: unexpected package db stack: " ++ show dbstack packageDbFlag | flagPackageConf implInfo = "package-conf" | otherwise = "package-db" -- ----------------------------------------------------------------------------- -- Boilerplate Monoid instance for GhcOptions instance Monoid GhcOptions where mempty = GhcOptions { ghcOptMode = mempty, ghcOptExtra = mempty, ghcOptExtraDefault = mempty, ghcOptInputFiles = mempty, ghcOptInputModules = mempty, ghcOptOutputFile = mempty, ghcOptOutputDynFile = mempty, ghcOptSourcePathClear = mempty, ghcOptSourcePath = mempty, ghcOptPackageKey = mempty, ghcOptPackageDBs = mempty, ghcOptPackages = mempty, ghcOptHideAllPackages = mempty, ghcOptNoAutoLinkPackages = mempty, ghcOptSigOf = mempty, ghcOptLinkLibs = mempty, ghcOptLinkLibPath = mempty, ghcOptLinkOptions = mempty, ghcOptLinkFrameworks = mempty, ghcOptNoLink = mempty, ghcOptLinkNoHsMain = mempty, ghcOptCcOptions = mempty, ghcOptCppOptions = mempty, ghcOptCppIncludePath = mempty, ghcOptCppIncludes = mempty, ghcOptFfiIncludes = mempty, ghcOptLanguage = mempty, ghcOptExtensions = mempty, ghcOptExtensionMap = mempty, ghcOptOptimisation = mempty, ghcOptDebugInfo = mempty, ghcOptProfilingMode = mempty, ghcOptSplitObjs = mempty, ghcOptNumJobs = mempty, ghcOptHPCDir = mempty, ghcOptGHCiScripts = mempty, ghcOptHiSuffix = mempty, ghcOptObjSuffix = mempty, ghcOptDynHiSuffix = mempty, ghcOptDynObjSuffix = mempty, ghcOptHiDir = mempty, ghcOptObjDir = mempty, ghcOptOutputDir = mempty, ghcOptStubDir = mempty, ghcOptDynLinkMode = mempty, ghcOptShared = mempty, ghcOptFPic = mempty, ghcOptDylibName = mempty, ghcOptRPaths = mempty, ghcOptVerbosity = mempty, ghcOptCabal = mempty } mappend a b = GhcOptions { ghcOptMode = combine ghcOptMode, ghcOptExtra = combine ghcOptExtra, ghcOptExtraDefault = combine ghcOptExtraDefault, ghcOptInputFiles = combine ghcOptInputFiles, ghcOptInputModules = combine ghcOptInputModules, ghcOptOutputFile = combine ghcOptOutputFile, ghcOptOutputDynFile = combine ghcOptOutputDynFile, ghcOptSourcePathClear = combine ghcOptSourcePathClear, ghcOptSourcePath = combine ghcOptSourcePath, ghcOptPackageKey = combine ghcOptPackageKey, ghcOptPackageDBs = combine ghcOptPackageDBs, ghcOptPackages = combine ghcOptPackages, ghcOptHideAllPackages = combine ghcOptHideAllPackages, ghcOptNoAutoLinkPackages = combine ghcOptNoAutoLinkPackages, ghcOptSigOf = combine ghcOptSigOf, ghcOptLinkLibs = combine ghcOptLinkLibs, ghcOptLinkLibPath = combine ghcOptLinkLibPath, ghcOptLinkOptions = combine ghcOptLinkOptions, ghcOptLinkFrameworks = combine ghcOptLinkFrameworks, ghcOptNoLink = combine ghcOptNoLink, ghcOptLinkNoHsMain = combine ghcOptLinkNoHsMain, ghcOptCcOptions = combine ghcOptCcOptions, ghcOptCppOptions = combine ghcOptCppOptions, ghcOptCppIncludePath = combine ghcOptCppIncludePath, ghcOptCppIncludes = combine ghcOptCppIncludes, ghcOptFfiIncludes = combine ghcOptFfiIncludes, ghcOptLanguage = combine ghcOptLanguage, ghcOptExtensions = combine ghcOptExtensions, ghcOptExtensionMap = combine ghcOptExtensionMap, ghcOptOptimisation = combine ghcOptOptimisation, ghcOptDebugInfo = combine ghcOptDebugInfo, ghcOptProfilingMode = combine ghcOptProfilingMode, ghcOptSplitObjs = combine ghcOptSplitObjs, ghcOptNumJobs = combine ghcOptNumJobs, ghcOptHPCDir = combine ghcOptHPCDir, ghcOptGHCiScripts = combine ghcOptGHCiScripts, ghcOptHiSuffix = combine ghcOptHiSuffix, ghcOptObjSuffix = combine ghcOptObjSuffix, ghcOptDynHiSuffix = combine ghcOptDynHiSuffix, ghcOptDynObjSuffix = combine ghcOptDynObjSuffix, ghcOptHiDir = combine ghcOptHiDir, ghcOptObjDir = combine ghcOptObjDir, ghcOptOutputDir = combine ghcOptOutputDir, ghcOptStubDir = combine ghcOptStubDir, ghcOptDynLinkMode = combine ghcOptDynLinkMode, ghcOptShared = combine ghcOptShared, ghcOptFPic = combine ghcOptFPic, ghcOptDylibName = combine ghcOptDylibName, ghcOptRPaths = combine ghcOptRPaths, ghcOptVerbosity = combine ghcOptVerbosity, ghcOptCabal = combine ghcOptCabal } where combine field = field a `mappend` field b Cabal-1.22.5.0/Distribution/Simple/Program/HcPkg.hs0000644000000000000000000003360712627136220020010 0ustar0000000000000000----------------------------------------------------------------------------- -- | -- Module : Distribution.Simple.Program.HcPkg -- Copyright : Duncan Coutts 2009, 2013 -- -- Maintainer : cabal-devel@haskell.org -- Portability : portable -- -- This module provides an library interface to the @hc-pkg@ program. -- Currently only GHC, GHCJS and LHC have hc-pkg programs. module Distribution.Simple.Program.HcPkg ( HcPkgInfo(..), init, invoke, register, reregister, unregister, expose, hide, dump, list, -- * Program invocations initInvocation, registerInvocation, reregisterInvocation, unregisterInvocation, exposeInvocation, hideInvocation, dumpInvocation, listInvocation, ) where import Prelude hiding (init) import Distribution.Package ( PackageId, InstalledPackageId(..) ) import Distribution.InstalledPackageInfo ( InstalledPackageInfo, InstalledPackageInfo_(..) , showInstalledPackageInfo , emptyInstalledPackageInfo, fieldsInstalledPackageInfo ) import Distribution.ParseUtils import Distribution.Simple.Compiler ( PackageDB(..), PackageDBStack ) import Distribution.Simple.Program.Types ( ConfiguredProgram(programId) ) import Distribution.Simple.Program.Run ( ProgramInvocation(..), IOEncoding(..), programInvocation , runProgramInvocation, getProgramInvocationOutput ) import Distribution.Text ( display, simpleParse ) import Distribution.Simple.Utils ( die ) import Distribution.Verbosity ( Verbosity, deafening, silent ) import Distribution.Compat.Exception ( catchExit ) import Data.Char ( isSpace ) import Data.List ( stripPrefix ) import System.FilePath as FilePath ( (), splitPath, splitDirectories, joinPath, isPathSeparator ) import qualified System.FilePath.Posix as FilePath.Posix -- | Information about the features and capabilities of an @hc-pkg@ -- program. -- data HcPkgInfo = HcPkgInfo { hcPkgProgram :: ConfiguredProgram , noPkgDbStack :: Bool -- ^ no package DB stack supported , noVerboseFlag :: Bool -- ^ hc-pkg does not support verbosity flags , flagPackageConf :: Bool -- ^ use package-conf option instead of package-db , useSingleFileDb :: Bool -- ^ requires single file package database } -- | Call @hc-pkg@ to initialise a package database at the location {path}. -- -- > hc-pkg init {path} -- init :: HcPkgInfo -> Verbosity -> FilePath -> IO () init hpi verbosity path = runProgramInvocation verbosity (initInvocation hpi verbosity path) -- | Run @hc-pkg@ using a given package DB stack, directly forwarding the -- provided command-line arguments to it. invoke :: HcPkgInfo -> Verbosity -> PackageDBStack -> [String] -> IO () invoke hpi verbosity dbStack extraArgs = runProgramInvocation verbosity invocation where args = packageDbStackOpts hpi dbStack ++ extraArgs invocation = programInvocation (hcPkgProgram hpi) args -- | Call @hc-pkg@ to register a package. -- -- > hc-pkg register {filename | -} [--user | --global | --package-db] -- register :: HcPkgInfo -> Verbosity -> PackageDBStack -> Either FilePath InstalledPackageInfo -> IO () register hpi verbosity packagedb pkgFile = runProgramInvocation verbosity (registerInvocation hpi verbosity packagedb pkgFile) -- | Call @hc-pkg@ to re-register a package. -- -- > hc-pkg register {filename | -} [--user | --global | --package-db] -- reregister :: HcPkgInfo -> Verbosity -> PackageDBStack -> Either FilePath InstalledPackageInfo -> IO () reregister hpi verbosity packagedb pkgFile = runProgramInvocation verbosity (reregisterInvocation hpi verbosity packagedb pkgFile) -- | Call @hc-pkg@ to unregister a package -- -- > hc-pkg unregister [pkgid] [--user | --global | --package-db] -- unregister :: HcPkgInfo -> Verbosity -> PackageDB -> PackageId -> IO () unregister hpi verbosity packagedb pkgid = runProgramInvocation verbosity (unregisterInvocation hpi verbosity packagedb pkgid) -- | Call @hc-pkg@ to expose a package. -- -- > hc-pkg expose [pkgid] [--user | --global | --package-db] -- expose :: HcPkgInfo -> Verbosity -> PackageDB -> PackageId -> IO () expose hpi verbosity packagedb pkgid = runProgramInvocation verbosity (exposeInvocation hpi verbosity packagedb pkgid) -- | Call @hc-pkg@ to hide a package. -- -- > hc-pkg hide [pkgid] [--user | --global | --package-db] -- hide :: HcPkgInfo -> Verbosity -> PackageDB -> PackageId -> IO () hide hpi verbosity packagedb pkgid = runProgramInvocation verbosity (hideInvocation hpi verbosity packagedb pkgid) -- | Call @hc-pkg@ to get all the details of all the packages in the given -- package database. -- dump :: HcPkgInfo -> Verbosity -> PackageDB -> IO [InstalledPackageInfo] dump hpi verbosity packagedb = do output <- getProgramInvocationOutput verbosity (dumpInvocation hpi verbosity packagedb) `catchExit` \_ -> die $ programId (hcPkgProgram hpi) ++ " dump failed" case parsePackages output of Left ok -> return ok _ -> die $ "failed to parse output of '" ++ programId (hcPkgProgram hpi) ++ " dump'" where parsePackages str = let parsed = map parseInstalledPackageInfo' (splitPkgs str) in case [ msg | ParseFailed msg <- parsed ] of [] -> Left [ setInstalledPackageId . maybe id mungePackagePaths (pkgRoot pkg) $ pkg | ParseOk _ pkg <- parsed ] msgs -> Right msgs parseInstalledPackageInfo' = parseFieldsFlat fieldsInstalledPackageInfo emptyInstalledPackageInfo --TODO: this could be a lot faster. We're doing normaliseLineEndings twice -- and converting back and forth with lines/unlines. splitPkgs :: String -> [String] splitPkgs = checkEmpty . map unlines . splitWith ("---" ==) . lines where -- Handle the case of there being no packages at all. checkEmpty [s] | all isSpace s = [] checkEmpty ss = ss splitWith :: (a -> Bool) -> [a] -> [[a]] splitWith p xs = ys : case zs of [] -> [] _:ws -> splitWith p ws where (ys,zs) = break p xs mungePackagePaths :: FilePath -> InstalledPackageInfo -> InstalledPackageInfo -- Perform path/URL variable substitution as per the Cabal ${pkgroot} spec -- (http://www.haskell.org/pipermail/libraries/2009-May/011772.html) -- Paths/URLs can be relative to ${pkgroot} or ${pkgrooturl}. -- The "pkgroot" is the directory containing the package database. mungePackagePaths pkgroot pkginfo = pkginfo { importDirs = mungePaths (importDirs pkginfo), includeDirs = mungePaths (includeDirs pkginfo), libraryDirs = mungePaths (libraryDirs pkginfo), frameworkDirs = mungePaths (frameworkDirs pkginfo), haddockInterfaces = mungePaths (haddockInterfaces pkginfo), haddockHTMLs = mungeUrls (haddockHTMLs pkginfo) } where mungePaths = map mungePath mungeUrls = map mungeUrl mungePath p = case stripVarPrefix "${pkgroot}" p of Just p' -> pkgroot p' Nothing -> p mungeUrl p = case stripVarPrefix "${pkgrooturl}" p of Just p' -> toUrlPath pkgroot p' Nothing -> p toUrlPath r p = "file:///" -- URLs always use posix style '/' separators: ++ FilePath.Posix.joinPath (r : FilePath.splitDirectories p) stripVarPrefix var p = case splitPath p of (root:path') -> case stripPrefix var root of Just [sep] | isPathSeparator sep -> Just (joinPath path') _ -> Nothing _ -> Nothing -- Older installed package info files did not have the installedPackageId -- field, so if it is missing then we fill it as the source package ID. setInstalledPackageId :: InstalledPackageInfo -> InstalledPackageInfo setInstalledPackageId pkginfo@InstalledPackageInfo { installedPackageId = InstalledPackageId "", sourcePackageId = pkgid } = pkginfo { --TODO use a proper named function for the conversion -- from source package id to installed package id installedPackageId = InstalledPackageId (display pkgid) } setInstalledPackageId pkginfo = pkginfo -- | Call @hc-pkg@ to get the source package Id of all the packages in the -- given package database. -- -- This is much less information than with 'dump', but also rather quicker. -- Note in particular that it does not include the 'InstalledPackageId', just -- the source 'PackageId' which is not necessarily unique in any package db. -- list :: HcPkgInfo -> Verbosity -> PackageDB -> IO [PackageId] list hpi verbosity packagedb = do output <- getProgramInvocationOutput verbosity (listInvocation hpi verbosity packagedb) `catchExit` \_ -> die $ programId (hcPkgProgram hpi) ++ " list failed" case parsePackageIds output of Just ok -> return ok _ -> die $ "failed to parse output of '" ++ programId (hcPkgProgram hpi) ++ " list'" where parsePackageIds = sequence . map simpleParse . words -------------------------- -- The program invocations -- initInvocation :: HcPkgInfo -> Verbosity -> FilePath -> ProgramInvocation initInvocation hpi verbosity path = programInvocation (hcPkgProgram hpi) args where args = ["init", path] ++ verbosityOpts hpi verbosity registerInvocation, reregisterInvocation :: HcPkgInfo -> Verbosity -> PackageDBStack -> Either FilePath InstalledPackageInfo -> ProgramInvocation registerInvocation = registerInvocation' "register" reregisterInvocation = registerInvocation' "update" registerInvocation' :: String -> HcPkgInfo -> Verbosity -> PackageDBStack -> Either FilePath InstalledPackageInfo -> ProgramInvocation registerInvocation' cmdname hpi verbosity packagedbs (Left pkgFile) = programInvocation (hcPkgProgram hpi) args where args = [cmdname, pkgFile] ++ (if noPkgDbStack hpi then [packageDbOpts hpi (last packagedbs)] else packageDbStackOpts hpi packagedbs) ++ verbosityOpts hpi verbosity registerInvocation' cmdname hpi verbosity packagedbs (Right pkgInfo) = (programInvocation (hcPkgProgram hpi) args) { progInvokeInput = Just (showInstalledPackageInfo pkgInfo), progInvokeInputEncoding = IOEncodingUTF8 } where args = [cmdname, "-"] ++ (if noPkgDbStack hpi then [packageDbOpts hpi (last packagedbs)] else packageDbStackOpts hpi packagedbs) ++ verbosityOpts hpi verbosity unregisterInvocation :: HcPkgInfo -> Verbosity -> PackageDB -> PackageId -> ProgramInvocation unregisterInvocation hpi verbosity packagedb pkgid = programInvocation (hcPkgProgram hpi) $ ["unregister", packageDbOpts hpi packagedb, display pkgid] ++ verbosityOpts hpi verbosity exposeInvocation :: HcPkgInfo -> Verbosity -> PackageDB -> PackageId -> ProgramInvocation exposeInvocation hpi verbosity packagedb pkgid = programInvocation (hcPkgProgram hpi) $ ["expose", packageDbOpts hpi packagedb, display pkgid] ++ verbosityOpts hpi verbosity hideInvocation :: HcPkgInfo -> Verbosity -> PackageDB -> PackageId -> ProgramInvocation hideInvocation hpi verbosity packagedb pkgid = programInvocation (hcPkgProgram hpi) $ ["hide", packageDbOpts hpi packagedb, display pkgid] ++ verbosityOpts hpi verbosity dumpInvocation :: HcPkgInfo -> Verbosity -> PackageDB -> ProgramInvocation dumpInvocation hpi _verbosity packagedb = (programInvocation (hcPkgProgram hpi) args) { progInvokeOutputEncoding = IOEncodingUTF8 } where args = ["dump", packageDbOpts hpi packagedb] ++ verbosityOpts hpi silent -- We use verbosity level 'silent' because it is important that we -- do not contaminate the output with info/debug messages. listInvocation :: HcPkgInfo -> Verbosity -> PackageDB -> ProgramInvocation listInvocation hpi _verbosity packagedb = (programInvocation (hcPkgProgram hpi) args) { progInvokeOutputEncoding = IOEncodingUTF8 } where args = ["list", "--simple-output", packageDbOpts hpi packagedb] ++ verbosityOpts hpi silent -- We use verbosity level 'silent' because it is important that we -- do not contaminate the output with info/debug messages. packageDbStackOpts :: HcPkgInfo -> PackageDBStack -> [String] packageDbStackOpts hpi dbstack = case dbstack of (GlobalPackageDB:UserPackageDB:dbs) -> "--global" : "--user" : map specific dbs (GlobalPackageDB:dbs) -> "--global" : ("--no-user-" ++ packageDbFlag hpi) : map specific dbs _ -> ierror where specific (SpecificPackageDB db) = "--" ++ packageDbFlag hpi ++ "=" ++ db specific _ = ierror ierror :: a ierror = error ("internal error: unexpected package db stack: " ++ show dbstack) packageDbFlag :: HcPkgInfo -> String packageDbFlag hpi | flagPackageConf hpi = "package-conf" | otherwise = "package-db" packageDbOpts :: HcPkgInfo -> PackageDB -> String packageDbOpts _ GlobalPackageDB = "--global" packageDbOpts _ UserPackageDB = "--user" packageDbOpts hpi (SpecificPackageDB db) = "--" ++ packageDbFlag hpi ++ "=" ++ db verbosityOpts :: HcPkgInfo -> Verbosity -> [String] verbosityOpts hpi v | noVerboseFlag hpi = [] | v >= deafening = ["-v2"] | v == silent = ["-v0"] | otherwise = [] Cabal-1.22.5.0/Distribution/Simple/Program/Hpc.hs0000644000000000000000000001014012627136220017511 0ustar0000000000000000----------------------------------------------------------------------------- -- | -- Module : Distribution.Simple.Program.Hpc -- Copyright : Thomas Tuegel 2011 -- -- Maintainer : cabal-devel@haskell.org -- Portability : portable -- -- This module provides an library interface to the @hpc@ program. module Distribution.Simple.Program.Hpc ( markup , union ) where import Distribution.ModuleName ( ModuleName ) import Distribution.Simple.Program.Run ( ProgramInvocation, programInvocation, runProgramInvocation ) import Distribution.Simple.Program.Types ( ConfiguredProgram(..) ) import Distribution.Text ( display ) import Distribution.Simple.Utils ( warn ) import Distribution.Verbosity ( Verbosity ) import Distribution.Version ( Version(..), orLaterVersion, withinRange ) -- | Invoke hpc with the given parameters. -- -- Prior to HPC version 0.7 (packaged with GHC 7.8), hpc did not handle -- multiple .mix paths correctly, so we print a warning, and only pass it the -- first path in the list. This means that e.g. test suites that import their -- library as a dependency can still work, but those that include the library -- modules directly (in other-modules) don't. markup :: ConfiguredProgram -> Version -> Verbosity -> FilePath -- ^ Path to .tix file -> [FilePath] -- ^ Paths to .mix file directories -> FilePath -- ^ Path where html output should be located -> [ModuleName] -- ^ List of modules to exclude from report -> IO () markup hpc hpcVer verbosity tixFile hpcDirs destDir excluded = do hpcDirs' <- if withinRange hpcVer (orLaterVersion version07) then return hpcDirs else do warn verbosity $ "Your version of HPC (" ++ display hpcVer ++ ") does not properly handle multiple search paths. " ++ "Coverage report generation may fail unexpectedly. These " ++ "issues are addressed in version 0.7 or later (GHC 7.8 or " ++ "later)." ++ if null droppedDirs then "" else " The following search paths have been abandoned: " ++ show droppedDirs return passedDirs runProgramInvocation verbosity (markupInvocation hpc tixFile hpcDirs' destDir excluded) where version07 = Version [0, 7] [] (passedDirs, droppedDirs) = splitAt 1 hpcDirs markupInvocation :: ConfiguredProgram -> FilePath -- ^ Path to .tix file -> [FilePath] -- ^ Paths to .mix file directories -> FilePath -- ^ Path where html output should be -- located -> [ModuleName] -- ^ List of modules to exclude from -- report -> ProgramInvocation markupInvocation hpc tixFile hpcDirs destDir excluded = let args = [ "markup", tixFile , "--destdir=" ++ destDir ] ++ map ("--hpcdir=" ++) hpcDirs ++ ["--exclude=" ++ display moduleName | moduleName <- excluded ] in programInvocation hpc args union :: ConfiguredProgram -> Verbosity -> [FilePath] -- ^ Paths to .tix files -> FilePath -- ^ Path to resultant .tix file -> [ModuleName] -- ^ List of modules to exclude from union -> IO () union hpc verbosity tixFiles outFile excluded = runProgramInvocation verbosity (unionInvocation hpc tixFiles outFile excluded) unionInvocation :: ConfiguredProgram -> [FilePath] -- ^ Paths to .tix files -> FilePath -- ^ Path to resultant .tix file -> [ModuleName] -- ^ List of modules to exclude from union -> ProgramInvocation unionInvocation hpc tixFiles outFile excluded = programInvocation hpc $ concat [ ["sum", "--union"] , tixFiles , ["--output=" ++ outFile] , ["--exclude=" ++ display moduleName | moduleName <- excluded ] ] Cabal-1.22.5.0/Distribution/Simple/Program/Ld.hs0000644000000000000000000000405112627136220017342 0ustar0000000000000000----------------------------------------------------------------------------- -- | -- Module : Distribution.Simple.Program.Ld -- Copyright : Duncan Coutts 2009 -- -- Maintainer : cabal-devel@haskell.org -- Portability : portable -- -- This module provides an library interface to the @ld@ linker program. module Distribution.Simple.Program.Ld ( combineObjectFiles, ) where import Distribution.Simple.Program.Types ( ConfiguredProgram(..) ) import Distribution.Simple.Program.Run ( programInvocation, multiStageProgramInvocation , runProgramInvocation ) import Distribution.Verbosity ( Verbosity ) import System.Directory ( renameFile ) import System.FilePath ( (<.>) ) -- | Call @ld -r@ to link a bunch of object files together. -- combineObjectFiles :: Verbosity -> ConfiguredProgram -> FilePath -> [FilePath] -> IO () combineObjectFiles verbosity ld target files = -- Unlike "ar", the "ld" tool is not designed to be used with xargs. That is, -- if we have more object files than fit on a single command line then we -- have a slight problem. What we have to do is link files in batches into -- a temp object file and then include that one in the next batch. let simpleArgs = ["-r", "-o", target] initialArgs = ["-r", "-o", target] middleArgs = ["-r", "-o", target, tmpfile] finalArgs = middleArgs simple = programInvocation ld simpleArgs initial = programInvocation ld initialArgs middle = programInvocation ld middleArgs final = programInvocation ld finalArgs invocations = multiStageProgramInvocation simple (initial, middle, final) files in run invocations where tmpfile = target <.> "tmp" -- perhaps should use a proper temp file run [] = return () run [inv] = runProgramInvocation verbosity inv run (inv:invs) = do runProgramInvocation verbosity inv renameFile target tmpfile run invs Cabal-1.22.5.0/Distribution/Simple/Program/Run.hs0000644000000000000000000002072112627136220017551 0ustar0000000000000000----------------------------------------------------------------------------- -- | -- Module : Distribution.Simple.Program.Run -- Copyright : Duncan Coutts 2009 -- -- Maintainer : cabal-devel@haskell.org -- Portability : portable -- -- This module provides a data type for program invocations and functions to -- run them. module Distribution.Simple.Program.Run ( ProgramInvocation(..), IOEncoding(..), emptyProgramInvocation, simpleProgramInvocation, programInvocation, multiStageProgramInvocation, runProgramInvocation, getProgramInvocationOutput, getEffectiveEnvironment, ) where import Distribution.Simple.Program.Types ( ConfiguredProgram(..), programPath ) import Distribution.Simple.Utils ( die, rawSystemExit, rawSystemIOWithEnv, rawSystemStdInOut , toUTF8, fromUTF8, normaliseLineEndings ) import Distribution.Verbosity ( Verbosity ) import Data.List ( foldl', unfoldr ) import qualified Data.Map as Map import Control.Monad ( when ) import System.Exit ( ExitCode(..), exitWith ) import Distribution.Compat.Environment ( getEnvironment ) -- | Represents a specific invocation of a specific program. -- -- This is used as an intermediate type between deciding how to call a program -- and actually doing it. This provides the opportunity to the caller to -- adjust how the program will be called. These invocations can either be run -- directly or turned into shell or batch scripts. -- data ProgramInvocation = ProgramInvocation { progInvokePath :: FilePath, progInvokeArgs :: [String], progInvokeEnv :: [(String, Maybe String)], progInvokeCwd :: Maybe FilePath, progInvokeInput :: Maybe String, progInvokeInputEncoding :: IOEncoding, progInvokeOutputEncoding :: IOEncoding } data IOEncoding = IOEncodingText -- locale mode text | IOEncodingUTF8 -- always utf8 emptyProgramInvocation :: ProgramInvocation emptyProgramInvocation = ProgramInvocation { progInvokePath = "", progInvokeArgs = [], progInvokeEnv = [], progInvokeCwd = Nothing, progInvokeInput = Nothing, progInvokeInputEncoding = IOEncodingText, progInvokeOutputEncoding = IOEncodingText } simpleProgramInvocation :: FilePath -> [String] -> ProgramInvocation simpleProgramInvocation path args = emptyProgramInvocation { progInvokePath = path, progInvokeArgs = args } programInvocation :: ConfiguredProgram -> [String] -> ProgramInvocation programInvocation prog args = emptyProgramInvocation { progInvokePath = programPath prog, progInvokeArgs = programDefaultArgs prog ++ args ++ programOverrideArgs prog, progInvokeEnv = programOverrideEnv prog } runProgramInvocation :: Verbosity -> ProgramInvocation -> IO () runProgramInvocation verbosity ProgramInvocation { progInvokePath = path, progInvokeArgs = args, progInvokeEnv = [], progInvokeCwd = Nothing, progInvokeInput = Nothing } = rawSystemExit verbosity path args runProgramInvocation verbosity ProgramInvocation { progInvokePath = path, progInvokeArgs = args, progInvokeEnv = envOverrides, progInvokeCwd = mcwd, progInvokeInput = Nothing } = do menv <- getEffectiveEnvironment envOverrides exitCode <- rawSystemIOWithEnv verbosity path args mcwd menv Nothing Nothing Nothing when (exitCode /= ExitSuccess) $ exitWith exitCode runProgramInvocation verbosity ProgramInvocation { progInvokePath = path, progInvokeArgs = args, progInvokeEnv = envOverrides, progInvokeCwd = mcwd, progInvokeInput = Just inputStr, progInvokeInputEncoding = encoding } = do menv <- getEffectiveEnvironment envOverrides (_, errors, exitCode) <- rawSystemStdInOut verbosity path args mcwd menv (Just input) True when (exitCode /= ExitSuccess) $ die $ "'" ++ path ++ "' exited with an error:\n" ++ errors where input = case encoding of IOEncodingText -> (inputStr, False) IOEncodingUTF8 -> (toUTF8 inputStr, True) -- use binary mode for -- utf8 getProgramInvocationOutput :: Verbosity -> ProgramInvocation -> IO String getProgramInvocationOutput verbosity ProgramInvocation { progInvokePath = path, progInvokeArgs = args, progInvokeEnv = envOverrides, progInvokeCwd = mcwd, progInvokeInput = minputStr, progInvokeOutputEncoding = encoding } = do let utf8 = case encoding of IOEncodingUTF8 -> True; _ -> False decode | utf8 = fromUTF8 . normaliseLineEndings | otherwise = id menv <- getEffectiveEnvironment envOverrides (output, errors, exitCode) <- rawSystemStdInOut verbosity path args mcwd menv input utf8 when (exitCode /= ExitSuccess) $ die $ "'" ++ path ++ "' exited with an error:\n" ++ errors return (decode output) where input = case minputStr of Nothing -> Nothing Just inputStr -> Just $ case encoding of IOEncodingText -> (inputStr, False) IOEncodingUTF8 -> (toUTF8 inputStr, True) -- use binary mode for utf8 -- | Return the current environment extended with the given overrides. -- getEffectiveEnvironment :: [(String, Maybe String)] -> IO (Maybe [(String, String)]) getEffectiveEnvironment [] = return Nothing getEffectiveEnvironment overrides = fmap (Just . Map.toList . apply overrides . Map.fromList) getEnvironment where apply os env = foldl' (flip update) env os update (var, Nothing) = Map.delete var update (var, Just val) = Map.insert var val -- | Like the unix xargs program. Useful for when we've got very long command -- lines that might overflow an OS limit on command line length and so you -- need to invoke a command multiple times to get all the args in. -- -- It takes four template invocations corresponding to the simple, initial, -- middle and last invocations. If the number of args given is small enough -- that we can get away with just a single invocation then the simple one is -- used: -- -- > $ simple args -- -- If the number of args given means that we need to use multiple invocations -- then the templates for the initial, middle and last invocations are used: -- -- > $ initial args_0 -- > $ middle args_1 -- > $ middle args_2 -- > ... -- > $ final args_n -- multiStageProgramInvocation :: ProgramInvocation -> (ProgramInvocation, ProgramInvocation, ProgramInvocation) -> [String] -> [ProgramInvocation] multiStageProgramInvocation simple (initial, middle, final) args = let argSize inv = length (progInvokePath inv) + foldl' (\s a -> length a + 1 + s) 1 (progInvokeArgs inv) fixedArgSize = maximum (map argSize [simple, initial, middle, final]) chunkSize = maxCommandLineSize - fixedArgSize in case splitChunks chunkSize args of [] -> [ simple ] [c] -> [ simple `appendArgs` c ] [c,c'] -> [ initial `appendArgs` c ] ++ [ final `appendArgs` c'] (c:cs) -> [ initial `appendArgs` c ] ++ [ middle `appendArgs` c'| c' <- init cs ] ++ [ final `appendArgs` c'| let c' = last cs ] where inv `appendArgs` as = inv { progInvokeArgs = progInvokeArgs inv ++ as } splitChunks len = unfoldr $ \s -> if null s then Nothing else Just (chunk len s) chunk len (s:_) | length s >= len = error toolong chunk len ss = chunk' [] len ss chunk' acc _ [] = (reverse acc,[]) chunk' acc len (s:ss) | len' < len = chunk' (s:acc) (len-len'-1) ss | otherwise = (reverse acc, s:ss) where len' = length s toolong = "multiStageProgramInvocation: a single program arg is larger " ++ "than the maximum command line length!" --FIXME: discover this at configure time or runtime on unix -- The value is 32k on Windows and posix specifies a minimum of 4k -- but all sensible unixes use more than 4k. -- we could use getSysVar ArgumentLimit but that's in the unix lib -- maxCommandLineSize :: Int maxCommandLineSize = 30 * 1024 Cabal-1.22.5.0/Distribution/Simple/Program/Script.hs0000644000000000000000000000645412627136220020260 0ustar0000000000000000----------------------------------------------------------------------------- -- | -- Module : Distribution.Simple.Program.Script -- Copyright : Duncan Coutts 2009 -- -- Maintainer : cabal-devel@haskell.org -- Portability : portable -- -- This module provides an library interface to the @hc-pkg@ program. -- Currently only GHC and LHC have hc-pkg programs. module Distribution.Simple.Program.Script ( invocationAsSystemScript, invocationAsShellScript, invocationAsBatchFile, ) where import Distribution.Simple.Program.Run ( ProgramInvocation(..) ) import Distribution.System ( OS(..) ) import Data.Maybe ( maybeToList ) -- | Generate a system script, either POSIX shell script or Windows batch file -- as appropriate for the given system. -- invocationAsSystemScript :: OS -> ProgramInvocation -> String invocationAsSystemScript Windows = invocationAsBatchFile invocationAsSystemScript _ = invocationAsShellScript -- | Generate a POSIX shell script that invokes a program. -- invocationAsShellScript :: ProgramInvocation -> String invocationAsShellScript ProgramInvocation { progInvokePath = path, progInvokeArgs = args, progInvokeEnv = envExtra, progInvokeCwd = mcwd, progInvokeInput = minput } = unlines $ [ "#!/bin/sh" ] ++ concatMap setEnv envExtra ++ [ "cd " ++ quote cwd | cwd <- maybeToList mcwd ] ++ [ (case minput of Nothing -> "" Just input -> "echo " ++ quote input ++ " | ") ++ unwords (map quote $ path : args) ++ " \"$@\""] where setEnv (var, Nothing) = ["unset " ++ var, "export " ++ var] setEnv (var, Just val) = ["export " ++ var ++ "=" ++ quote val] quote :: String -> String quote s = "'" ++ escape s ++ "'" escape [] = [] escape ('\'':cs) = "'\\''" ++ escape cs escape (c :cs) = c : escape cs -- | Generate a Windows batch file that invokes a program. -- invocationAsBatchFile :: ProgramInvocation -> String invocationAsBatchFile ProgramInvocation { progInvokePath = path, progInvokeArgs = args, progInvokeEnv = envExtra, progInvokeCwd = mcwd, progInvokeInput = minput } = unlines $ [ "@echo off" ] ++ map setEnv envExtra ++ [ "cd \"" ++ cwd ++ "\"" | cwd <- maybeToList mcwd ] ++ case minput of Nothing -> [ path ++ concatMap (' ':) args ] Just input -> [ "(" ] ++ [ "echo " ++ escape line | line <- lines input ] ++ [ ") | " ++ "\"" ++ path ++ "\"" ++ concatMap (\arg -> ' ':quote arg) args ] where setEnv (var, Nothing) = "set " ++ var ++ "=" setEnv (var, Just val) = "set " ++ var ++ "=" ++ escape val quote :: String -> String quote s = "\"" ++ escapeQ s ++ "\"" escapeQ [] = [] escapeQ ('"':cs) = "\"\"\"" ++ escapeQ cs escapeQ (c :cs) = c : escapeQ cs escape [] = [] escape ('|':cs) = "^|" ++ escape cs escape ('<':cs) = "^<" ++ escape cs escape ('>':cs) = "^>" ++ escape cs escape ('&':cs) = "^&" ++ escape cs escape ('(':cs) = "^(" ++ escape cs escape (')':cs) = "^)" ++ escape cs escape ('^':cs) = "^^" ++ escape cs escape (c :cs) = c : escape cs Cabal-1.22.5.0/Distribution/Simple/Program/Strip.hs0000644000000000000000000000614212627136220020107 0ustar0000000000000000----------------------------------------------------------------------------- -- | -- Module : Distribution.Simple.Program.Strip -- -- Maintainer : cabal-devel@haskell.org -- Portability : portable -- -- This module provides an library interface to the @strip@ program. module Distribution.Simple.Program.Strip (stripLib, stripExe) where import Distribution.Simple.Program (ProgramConfiguration, lookupProgram , programVersion, rawSystemProgram , stripProgram) import Distribution.Simple.Utils (warn) import Distribution.System (Arch(..), Platform(..), OS (..), buildOS) import Distribution.Verbosity (Verbosity) import Distribution.Version (orLaterVersion, withinRange) import Control.Monad (unless) import Data.Version (Version(..)) import System.FilePath (takeBaseName) runStrip :: Verbosity -> ProgramConfiguration -> FilePath -> [String] -> IO () runStrip verbosity progConf path args = case lookupProgram stripProgram progConf of Just strip -> rawSystemProgram verbosity strip (path:args) Nothing -> unless (buildOS == Windows) $ -- Don't bother warning on windows, we don't expect them to -- have the strip program anyway. warn verbosity $ "Unable to strip executable or library '" ++ (takeBaseName path) ++ "' (missing the 'strip' program)" stripExe :: Verbosity -> Platform -> ProgramConfiguration -> FilePath -> IO () stripExe verbosity (Platform _arch os) conf path = runStrip verbosity conf path args where args = case os of OSX -> ["-x"] -- By default, stripping the ghc binary on at least -- some OS X installations causes: -- HSbase-3.0.o: unknown symbol `_environ'" -- The -x flag fixes that. _ -> [] stripLib :: Verbosity -> Platform -> ProgramConfiguration -> FilePath -> IO () stripLib verbosity (Platform arch os) conf path = do case os of OSX -> -- '--strip-unneeded' is not supported on OS X, iOS or -- Solaris. See #1630. return () IOS -> return () Solaris -> return () Windows -> -- Stripping triggers a bug in 'strip.exe' for -- libraries with lots identically named modules. See -- #1784. return() Linux | arch == I386 -> -- Versions of 'strip' on 32-bit Linux older than 2.18 are -- broken. See #2339. let okVersion = orLaterVersion (Version [2,18] []) in case programVersion =<< lookupProgram stripProgram conf of Just v | withinRange v okVersion -> runStrip verbosity conf path args _ -> warn verbosity $ "Unable to strip library '" ++ (takeBaseName path) ++ "' (version of 'strip' too old; " ++ "requires >= 2.18 on 32-bit Linux)" _ -> runStrip verbosity conf path args where args = ["--strip-unneeded"] Cabal-1.22.5.0/Distribution/Simple/Program/Types.hs0000644000000000000000000001405612627136220020115 0ustar0000000000000000{-# LANGUAGE DeriveGeneric #-} ----------------------------------------------------------------------------- -- | -- Module : Distribution.Simple.Program.Types -- Copyright : Isaac Jones 2006, Duncan Coutts 2007-2009 -- -- Maintainer : cabal-devel@haskell.org -- Portability : portable -- -- This provides an abstraction which deals with configuring and running -- programs. A 'Program' is a static notion of a known program. A -- 'ConfiguredProgram' is a 'Program' that has been found on the current -- machine and is ready to be run (possibly with some user-supplied default -- args). Configuring a program involves finding its location and if necessary -- finding its version. There's reasonable default behavior for trying to find -- \"foo\" in PATH, being able to override its location, etc. -- module Distribution.Simple.Program.Types ( -- * Program and functions for constructing them Program(..), ProgramSearchPath, ProgramSearchPathEntry(..), simpleProgram, -- * Configured program and related functions ConfiguredProgram(..), programPath, suppressOverrideArgs, ProgArg, ProgramLocation(..), simpleConfiguredProgram, ) where import Distribution.Simple.Program.Find ( ProgramSearchPath, ProgramSearchPathEntry(..) , findProgramOnSearchPath ) import Distribution.Version ( Version ) import Distribution.Verbosity ( Verbosity ) import Distribution.Compat.Binary (Binary) import qualified Data.Map as Map import GHC.Generics (Generic) -- | Represents a program which can be configured. -- -- Note: rather than constructing this directly, start with 'simpleProgram' and -- override any extra fields. -- data Program = Program { -- | The simple name of the program, eg. ghc programName :: String, -- | A function to search for the program if its location was not -- specified by the user. Usually this will just be a call to -- 'findProgramOnSearchPath'. -- -- It is supplied with the prevailing search path which will typically -- just be used as-is, but can be extended or ignored as needed. programFindLocation :: Verbosity -> ProgramSearchPath -> IO (Maybe FilePath), -- | Try to find the version of the program. For many programs this is -- not possible or is not necessary so it's OK to return Nothing. programFindVersion :: Verbosity -> FilePath -> IO (Maybe Version), -- | A function to do any additional configuration after we have -- located the program (and perhaps identified its version). For example -- it could add args, or environment vars. programPostConf :: Verbosity -> ConfiguredProgram -> IO ConfiguredProgram } type ProgArg = String -- | Represents a program which has been configured and is thus ready to be run. -- -- These are usually made by configuring a 'Program', but if you have to -- construct one directly then start with 'simpleConfiguredProgram' and -- override any extra fields. -- data ConfiguredProgram = ConfiguredProgram { -- | Just the name again programId :: String, -- | The version of this program, if it is known. programVersion :: Maybe Version, -- | Default command-line args for this program. -- These flags will appear first on the command line, so they can be -- overridden by subsequent flags. programDefaultArgs :: [String], -- | Override command-line args for this program. -- These flags will appear last on the command line, so they override -- all earlier flags. programOverrideArgs :: [String], -- | Override environment variables for this program. -- These env vars will extend\/override the prevailing environment of -- the current to form the environment for the new process. programOverrideEnv :: [(String, Maybe String)], -- | A key-value map listing various properties of the program, useful -- for feature detection. Populated during the configuration step, key -- names depend on the specific program. programProperties :: Map.Map String String, -- | Location of the program. eg. @\/usr\/bin\/ghc-6.4@ programLocation :: ProgramLocation } deriving (Eq, Generic, Read, Show) instance Binary ConfiguredProgram -- | Where a program was found. Also tells us whether it's specified by user or -- not. This includes not just the path, but the program as well. data ProgramLocation = UserSpecified { locationPath :: FilePath } -- ^The user gave the path to this program, -- eg. --ghc-path=\/usr\/bin\/ghc-6.6 | FoundOnSystem { locationPath :: FilePath } -- ^The program was found automatically. deriving (Eq, Generic, Read, Show) instance Binary ProgramLocation -- | The full path of a configured program. programPath :: ConfiguredProgram -> FilePath programPath = locationPath . programLocation -- | Suppress any extra arguments added by the user. suppressOverrideArgs :: ConfiguredProgram -> ConfiguredProgram suppressOverrideArgs prog = prog { programOverrideArgs = [] } -- | Make a simple named program. -- -- By default we'll just search for it in the path and not try to find the -- version name. You can override these behaviours if necessary, eg: -- -- > simpleProgram "foo" { programFindLocation = ... , programFindVersion ... } -- simpleProgram :: String -> Program simpleProgram name = Program { programName = name, programFindLocation = \v p -> findProgramOnSearchPath v p name, programFindVersion = \_ _ -> return Nothing, programPostConf = \_ p -> return p } -- | Make a simple 'ConfiguredProgram'. -- -- > simpleConfiguredProgram "foo" (FoundOnSystem path) -- simpleConfiguredProgram :: String -> ProgramLocation -> ConfiguredProgram simpleConfiguredProgram name loc = ConfiguredProgram { programId = name, programVersion = Nothing, programDefaultArgs = [], programOverrideArgs = [], programOverrideEnv = [], programProperties = Map.empty, programLocation = loc } Cabal-1.22.5.0/Distribution/Simple/Test/0000755000000000000000000000000012627136220015757 5ustar0000000000000000Cabal-1.22.5.0/Distribution/Simple/Test/ExeV10.hs0000644000000000000000000001515412627136220017331 0ustar0000000000000000module Distribution.Simple.Test.ExeV10 ( runTest ) where import Distribution.Compat.CreatePipe ( createPipe ) import Distribution.Compat.Environment ( getEnvironment ) import qualified Distribution.PackageDescription as PD import Distribution.Simple.Build.PathsModule ( pkgPathEnvVar ) import Distribution.Simple.BuildPaths ( exeExtension ) import Distribution.Simple.Compiler ( compilerInfo ) import Distribution.Simple.Hpc ( guessWay, markupTest, tixDir, tixFilePath ) import Distribution.Simple.InstallDirs ( fromPathTemplate, initialPathTemplateEnv, PathTemplateVariable(..) , substPathTemplate , toPathTemplate, PathTemplate ) import qualified Distribution.Simple.LocalBuildInfo as LBI import Distribution.Simple.Setup ( TestFlags(..), TestShowDetails(..), fromFlag, configCoverage ) import Distribution.Simple.Test.Log import Distribution.Simple.Utils ( die, notice, rawSystemIOWithEnv, addLibraryPath ) import Distribution.System ( Platform (..) ) import Distribution.TestSuite import Distribution.Text import Distribution.Verbosity ( normal ) import Control.Concurrent (forkIO) import Control.Monad ( unless, void, when ) import System.Directory ( createDirectoryIfMissing, doesDirectoryExist, doesFileExist , getCurrentDirectory, removeDirectoryRecursive ) import System.Exit ( ExitCode(..) ) import System.FilePath ( (), (<.>) ) import System.IO ( hGetContents, hPutStr, stdout ) runTest :: PD.PackageDescription -> LBI.LocalBuildInfo -> TestFlags -> PD.TestSuite -> IO TestSuiteLog runTest pkg_descr lbi flags suite = do let isCoverageEnabled = fromFlag $ configCoverage $ LBI.configFlags lbi way = guessWay lbi tixDir_ = tixDir distPref way $ PD.testName suite pwd <- getCurrentDirectory existingEnv <- getEnvironment let cmd = LBI.buildDir lbi PD.testName suite PD.testName suite <.> exeExtension -- Check that the test executable exists. exists <- doesFileExist cmd unless exists $ die $ "Error: Could not find test program \"" ++ cmd ++ "\". Did you build the package first?" -- Remove old .tix files if appropriate. unless (fromFlag $ testKeepTix flags) $ do exists' <- doesDirectoryExist tixDir_ when exists' $ removeDirectoryRecursive tixDir_ -- Create directory for HPC files. createDirectoryIfMissing True tixDir_ -- Write summary notices indicating start of test suite notice verbosity $ summarizeSuiteStart $ PD.testName suite (rOut, wOut) <- createPipe -- Read test executable's output lazily (returns immediately) logText <- hGetContents rOut -- Force the IO manager to drain the test output pipe void $ forkIO $ length logText `seq` return () -- '--show-details=streaming': print the log output in another thread when (details == Streaming) $ void $ forkIO $ hPutStr stdout logText -- Run the test executable let opts = map (testOption pkg_descr lbi suite) (testOptions flags) dataDirPath = pwd PD.dataDir pkg_descr tixFile = pwd tixFilePath distPref way (PD.testName suite) pkgPathEnv = (pkgPathEnvVar pkg_descr "datadir", dataDirPath) : existingEnv shellEnv = [("HPCTIXFILE", tixFile) | isCoverageEnabled] ++ pkgPathEnv -- Add (DY)LD_LIBRARY_PATH if needed shellEnv' <- if LBI.withDynExe lbi then do let (Platform _ os) = LBI.hostPlatform lbi clbi = LBI.getComponentLocalBuildInfo lbi (LBI.CTestName (PD.testName suite)) paths <- LBI.depLibraryPaths True False lbi clbi return (addLibraryPath os paths shellEnv) else return shellEnv exit <- rawSystemIOWithEnv verbosity cmd opts Nothing (Just shellEnv') -- these handles are automatically closed Nothing (Just wOut) (Just wOut) -- Generate TestSuiteLog from executable exit code and a machine- -- readable test log. let suiteLog = buildLog exit -- Write summary notice to log file indicating start of test suite appendFile (logFile suiteLog) $ summarizeSuiteStart $ PD.testName suite -- Append contents of temporary log file to the final human- -- readable log file appendFile (logFile suiteLog) logText -- Write end-of-suite summary notice to log file appendFile (logFile suiteLog) $ summarizeSuiteFinish suiteLog -- Show the contents of the human-readable log file on the terminal -- if there is a failure and/or detailed output is requested let whenPrinting = when $ (details > Never) && (not (suitePassed $ testLogs suiteLog) || details == Always) -- verbosity overrides show-details && verbosity >= normal -- if streaming, we already printed the log && details /= Streaming whenPrinting $ putStr $ unlines $ lines logText -- Write summary notice to terminal indicating end of test suite notice verbosity $ summarizeSuiteFinish suiteLog when isCoverageEnabled $ markupTest verbosity lbi distPref (display $ PD.package pkg_descr) suite return suiteLog where distPref = fromFlag $ testDistPref flags verbosity = fromFlag $ testVerbosity flags details = fromFlag $ testShowDetails flags testLogDir = distPref "test" buildLog exit = let r = case exit of ExitSuccess -> Pass ExitFailure c -> Fail $ "exit code: " ++ show c n = PD.testName suite l = TestLog { testName = n , testOptionsReturned = [] , testResult = r } in TestSuiteLog { testSuiteName = n , testLogs = l , logFile = testLogDir testSuiteLogPath (fromFlag $ testHumanLog flags) pkg_descr lbi n l } -- TODO: This is abusing the notion of a 'PathTemplate'. The result isn't -- necessarily a path. testOption :: PD.PackageDescription -> LBI.LocalBuildInfo -> PD.TestSuite -> PathTemplate -> String testOption pkg_descr lbi suite template = fromPathTemplate $ substPathTemplate env template where env = initialPathTemplateEnv (PD.package pkg_descr) (LBI.pkgKey lbi) (compilerInfo $ LBI.compiler lbi) (LBI.hostPlatform lbi) ++ [(TestSuiteNameVar, toPathTemplate $ PD.testName suite)] Cabal-1.22.5.0/Distribution/Simple/Test/LibV09.hs0000644000000000000000000002514612627136220017330 0ustar0000000000000000module Distribution.Simple.Test.LibV09 ( runTest -- Test stub , simpleTestStub , stubFilePath, stubMain, stubName, stubWriteLog , writeSimpleTestStub ) where import Distribution.Compat.CreatePipe ( createPipe ) import Distribution.Compat.Environment ( getEnvironment ) import Distribution.Compat.TempFile ( openTempFile ) import Distribution.ModuleName ( ModuleName ) import qualified Distribution.PackageDescription as PD import Distribution.Simple.Build.PathsModule ( pkgPathEnvVar ) import Distribution.Simple.BuildPaths ( exeExtension ) import Distribution.Simple.Compiler ( compilerInfo ) import Distribution.Simple.Hpc ( guessWay, markupTest, tixDir, tixFilePath ) import Distribution.Simple.InstallDirs ( fromPathTemplate, initialPathTemplateEnv, PathTemplateVariable(..) , substPathTemplate , toPathTemplate, PathTemplate ) import qualified Distribution.Simple.LocalBuildInfo as LBI import Distribution.Simple.Setup ( TestFlags(..), TestShowDetails(..), fromFlag, configCoverage ) import Distribution.Simple.Test.Log import Distribution.Simple.Utils ( die, notice, rawSystemIOWithEnv, addLibraryPath ) import Distribution.System ( Platform (..) ) import Distribution.TestSuite import Distribution.Text import Distribution.Verbosity ( normal ) import Control.Exception ( bracket ) import Control.Monad ( when, unless ) import Data.Maybe ( mapMaybe ) import System.Directory ( createDirectoryIfMissing, doesDirectoryExist, doesFileExist , getCurrentDirectory, removeDirectoryRecursive, removeFile , setCurrentDirectory ) import System.Exit ( ExitCode(..), exitWith ) import System.FilePath ( (), (<.>) ) import System.IO ( hClose, hGetContents, hPutStr ) runTest :: PD.PackageDescription -> LBI.LocalBuildInfo -> TestFlags -> PD.TestSuite -> IO TestSuiteLog runTest pkg_descr lbi flags suite = do let isCoverageEnabled = fromFlag $ configCoverage $ LBI.configFlags lbi way = guessWay lbi pwd <- getCurrentDirectory existingEnv <- getEnvironment let cmd = LBI.buildDir lbi stubName suite stubName suite <.> exeExtension -- Check that the test executable exists. exists <- doesFileExist cmd unless exists $ die $ "Error: Could not find test program \"" ++ cmd ++ "\". Did you build the package first?" -- Remove old .tix files if appropriate. unless (fromFlag $ testKeepTix flags) $ do let tDir = tixDir distPref way $ PD.testName suite exists' <- doesDirectoryExist tDir when exists' $ removeDirectoryRecursive tDir -- Create directory for HPC files. createDirectoryIfMissing True $ tixDir distPref way $ PD.testName suite -- Write summary notices indicating start of test suite notice verbosity $ summarizeSuiteStart $ PD.testName suite suiteLog <- bracket openCabalTemp deleteIfExists $ \tempLog -> do (rIn, wIn) <- createPipe (rOut, wOut) <- createPipe -- Prepare standard input for test executable --appendFile tempInput $ show (tempInput, PD.testName suite) hPutStr wIn $ show (tempLog, PD.testName suite) hClose wIn -- Run test executable _ <- do let opts = map (testOption pkg_descr lbi suite) $ testOptions flags dataDirPath = pwd PD.dataDir pkg_descr tixFile = pwd tixFilePath distPref way (PD.testName suite) pkgPathEnv = (pkgPathEnvVar pkg_descr "datadir", dataDirPath) : existingEnv shellEnv = [("HPCTIXFILE", tixFile) | isCoverageEnabled] ++ pkgPathEnv -- Add (DY)LD_LIBRARY_PATH if needed shellEnv' <- if LBI.withDynExe lbi then do let (Platform _ os) = LBI.hostPlatform lbi clbi = LBI.getComponentLocalBuildInfo lbi (LBI.CTestName (PD.testName suite)) paths <- LBI.depLibraryPaths True False lbi clbi return (addLibraryPath os paths shellEnv) else return shellEnv rawSystemIOWithEnv verbosity cmd opts Nothing (Just shellEnv') -- these handles are closed automatically (Just rIn) (Just wOut) (Just wOut) -- Generate final log file name let finalLogName l = testLogDir testSuiteLogPath (fromFlag $ testHumanLog flags) pkg_descr lbi (testSuiteName l) (testLogs l) -- Generate TestSuiteLog from executable exit code and a machine- -- readable test log suiteLog <- fmap ((\l -> l { logFile = finalLogName l }) . read) $ readFile tempLog -- Write summary notice to log file indicating start of test suite appendFile (logFile suiteLog) $ summarizeSuiteStart $ PD.testName suite -- Append contents of temporary log file to the final human- -- readable log file logText <- hGetContents rOut appendFile (logFile suiteLog) logText -- Write end-of-suite summary notice to log file appendFile (logFile suiteLog) $ summarizeSuiteFinish suiteLog -- Show the contents of the human-readable log file on the terminal -- if there is a failure and/or detailed output is requested let details = fromFlag $ testShowDetails flags whenPrinting = when $ (details > Never) && (not (suitePassed $ testLogs suiteLog) || details == Always) && verbosity >= normal whenPrinting $ putStr $ unlines $ lines logText return suiteLog -- Write summary notice to terminal indicating end of test suite notice verbosity $ summarizeSuiteFinish suiteLog when isCoverageEnabled $ markupTest verbosity lbi distPref (display $ PD.package pkg_descr) suite return suiteLog where deleteIfExists file = do exists <- doesFileExist file when exists $ removeFile file testLogDir = distPref "test" openCabalTemp = do (f, h) <- openTempFile testLogDir $ "cabal-test-" <.> "log" hClose h >> return f distPref = fromFlag $ testDistPref flags verbosity = fromFlag $ testVerbosity flags -- TODO: This is abusing the notion of a 'PathTemplate'. The result isn't -- necessarily a path. testOption :: PD.PackageDescription -> LBI.LocalBuildInfo -> PD.TestSuite -> PathTemplate -> String testOption pkg_descr lbi suite template = fromPathTemplate $ substPathTemplate env template where env = initialPathTemplateEnv (PD.package pkg_descr) (LBI.pkgKey lbi) (compilerInfo $ LBI.compiler lbi) (LBI.hostPlatform lbi) ++ [(TestSuiteNameVar, toPathTemplate $ PD.testName suite)] -- Test stub ---------- -- | The name of the stub executable associated with a library 'TestSuite'. stubName :: PD.TestSuite -> FilePath stubName t = PD.testName t ++ "Stub" -- | The filename of the source file for the stub executable associated with a -- library 'TestSuite'. stubFilePath :: PD.TestSuite -> FilePath stubFilePath t = stubName t <.> "hs" -- | Write the source file for a library 'TestSuite' stub executable. writeSimpleTestStub :: PD.TestSuite -- ^ library 'TestSuite' for which a stub -- is being created -> FilePath -- ^ path to directory where stub source -- should be located -> IO () writeSimpleTestStub t dir = do createDirectoryIfMissing True dir let filename = dir stubFilePath t PD.TestSuiteLibV09 _ m = PD.testInterface t writeFile filename $ simpleTestStub m -- | Source code for library test suite stub executable simpleTestStub :: ModuleName -> String simpleTestStub m = unlines [ "module Main ( main ) where" , "import Distribution.Simple.Test.LibV09 ( stubMain )" , "import " ++ show (disp m) ++ " ( tests )" , "main :: IO ()" , "main = stubMain tests" ] -- | Main function for test stubs. Once, it was written directly into the stub, -- but minimizing the amount of code actually in the stub maximizes the number -- of detectable errors when Cabal is compiled. stubMain :: IO [Test] -> IO () stubMain tests = do (f, n) <- fmap read getContents dir <- getCurrentDirectory results <- tests >>= stubRunTests setCurrentDirectory dir stubWriteLog f n results -- | The test runner used in library "TestSuite" stub executables. Runs a list -- of 'Test's. An executable calling this function is meant to be invoked as -- the child of a Cabal process during @.\/setup test@. A 'TestSuiteLog', -- provided by Cabal, is read from the standard input; it supplies the name of -- the test suite and the location of the machine-readable test suite log file. -- Human-readable log information is written to the standard output for capture -- by the calling Cabal process. stubRunTests :: [Test] -> IO TestLogs stubRunTests tests = do logs <- mapM stubRunTests' tests return $ GroupLogs "Default" logs where stubRunTests' (Test t) = do l <- run t >>= finish summarizeTest normal Always l return l where finish (Finished result) = return TestLog { testName = name t , testOptionsReturned = defaultOptions t , testResult = result } finish (Progress _ next) = next >>= finish stubRunTests' g@(Group {}) = do logs <- mapM stubRunTests' $ groupTests g return $ GroupLogs (groupName g) logs stubRunTests' (ExtraOptions _ t) = stubRunTests' t maybeDefaultOption opt = maybe Nothing (\d -> Just (optionName opt, d)) $ optionDefault opt defaultOptions testInst = mapMaybe maybeDefaultOption $ options testInst -- | From a test stub, write the 'TestSuiteLog' to temporary file for the calling -- Cabal process to read. stubWriteLog :: FilePath -> String -> TestLogs -> IO () stubWriteLog f n logs = do let testLog = TestSuiteLog { testSuiteName = n, testLogs = logs, logFile = f } writeFile (logFile testLog) $ show testLog when (suiteError logs) $ exitWith $ ExitFailure 2 when (suiteFailed logs) $ exitWith $ ExitFailure 1 exitWith ExitSuccess Cabal-1.22.5.0/Distribution/Simple/Test/Log.hs0000644000000000000000000001365612627136220017047 0ustar0000000000000000module Distribution.Simple.Test.Log ( PackageLog(..) , TestLogs(..) , TestSuiteLog(..) , countTestResults , localPackageLog , summarizePackage , summarizeSuiteFinish, summarizeSuiteStart , summarizeTest , suiteError, suiteFailed, suitePassed , testSuiteLogPath ) where import Distribution.Package ( PackageId ) import qualified Distribution.PackageDescription as PD import Distribution.Simple.Compiler ( Compiler(..), compilerInfo, CompilerId ) import Distribution.Simple.InstallDirs ( fromPathTemplate, initialPathTemplateEnv, PathTemplateVariable(..) , substPathTemplate , toPathTemplate, PathTemplate ) import qualified Distribution.Simple.LocalBuildInfo as LBI import Distribution.Simple.Setup ( TestShowDetails(..) ) import Distribution.Simple.Utils ( notice ) import Distribution.System ( Platform ) import Distribution.TestSuite ( Options, Result(..) ) import Distribution.Verbosity ( Verbosity ) import Control.Monad ( when ) import Data.Char ( toUpper ) -- | Logs all test results for a package, broken down first by test suite and -- then by test case. data PackageLog = PackageLog { package :: PackageId , compiler :: CompilerId , platform :: Platform , testSuites :: [TestSuiteLog] } deriving (Read, Show, Eq) -- | A 'PackageLog' with package and platform information specified. localPackageLog :: PD.PackageDescription -> LBI.LocalBuildInfo -> PackageLog localPackageLog pkg_descr lbi = PackageLog { package = PD.package pkg_descr , compiler = compilerId $ LBI.compiler lbi , platform = LBI.hostPlatform lbi , testSuites = [] } -- | Logs test suite results, itemized by test case. data TestSuiteLog = TestSuiteLog { testSuiteName :: String , testLogs :: TestLogs , logFile :: FilePath -- path to human-readable log file } deriving (Read, Show, Eq) data TestLogs = TestLog { testName :: String , testOptionsReturned :: Options , testResult :: Result } | GroupLogs String [TestLogs] deriving (Read, Show, Eq) -- | Count the number of pass, fail, and error test results in a 'TestLogs' -- tree. countTestResults :: TestLogs -> (Int, Int, Int) -- ^ Passes, fails, and errors, -- respectively. countTestResults = go (0, 0, 0) where go (p, f, e) (TestLog { testResult = r }) = case r of Pass -> (p + 1, f, e) Fail _ -> (p, f + 1, e) Error _ -> (p, f, e + 1) go (p, f, e) (GroupLogs _ ts) = foldl go (p, f, e) ts -- | From a 'TestSuiteLog', determine if the test suite passed. suitePassed :: TestLogs -> Bool suitePassed l = case countTestResults l of (_, 0, 0) -> True _ -> False -- | From a 'TestSuiteLog', determine if the test suite failed. suiteFailed :: TestLogs -> Bool suiteFailed l = case countTestResults l of (_, 0, _) -> False _ -> True -- | From a 'TestSuiteLog', determine if the test suite encountered errors. suiteError :: TestLogs -> Bool suiteError l = case countTestResults l of (_, _, 0) -> False _ -> True resultString :: TestLogs -> String resultString l | suiteError l = "error" | suiteFailed l = "fail" | otherwise = "pass" testSuiteLogPath :: PathTemplate -> PD.PackageDescription -> LBI.LocalBuildInfo -> String -- ^ test suite name -> TestLogs -- ^ test suite results -> FilePath testSuiteLogPath template pkg_descr lbi name result = fromPathTemplate $ substPathTemplate env template where env = initialPathTemplateEnv (PD.package pkg_descr) (LBI.pkgKey lbi) (compilerInfo $ LBI.compiler lbi) (LBI.hostPlatform lbi) ++ [ (TestSuiteNameVar, toPathTemplate name) , (TestSuiteResultVar, toPathTemplate $ resultString result) ] -- | Print a summary to the console after all test suites have been run -- indicating the number of successful test suites and cases. Returns 'True' if -- all test suites passed and 'False' otherwise. summarizePackage :: Verbosity -> PackageLog -> IO Bool summarizePackage verbosity packageLog = do let counts = map (countTestResults . testLogs) $ testSuites packageLog (passed, failed, errors) = foldl1 addTriple counts totalCases = passed + failed + errors passedSuites = length $ filter (suitePassed . testLogs) $ testSuites packageLog totalSuites = length $ testSuites packageLog notice verbosity $ show passedSuites ++ " of " ++ show totalSuites ++ " test suites (" ++ show passed ++ " of " ++ show totalCases ++ " test cases) passed." return $! passedSuites == totalSuites where addTriple (p1, f1, e1) (p2, f2, e2) = (p1 + p2, f1 + f2, e1 + e2) -- | Print a summary of a single test case's result to the console, supressing -- output for certain verbosity or test filter levels. summarizeTest :: Verbosity -> TestShowDetails -> TestLogs -> IO () summarizeTest _ _ (GroupLogs {}) = return () summarizeTest verbosity details t = when shouldPrint $ notice verbosity $ "Test case " ++ testName t ++ ": " ++ show (testResult t) where shouldPrint = (details > Never) && (notPassed || details == Always) notPassed = testResult t /= Pass -- | Print a summary of the test suite's results on the console, suppressing -- output for certain verbosity or test filter levels. summarizeSuiteFinish :: TestSuiteLog -> String summarizeSuiteFinish testLog = unlines [ "Test suite " ++ testSuiteName testLog ++ ": " ++ resStr , "Test suite logged to: " ++ logFile testLog ] where resStr = map toUpper (resultString $ testLogs testLog) summarizeSuiteStart :: String -> String summarizeSuiteStart n = "Test suite " ++ n ++ ": RUNNING...\n" Cabal-1.22.5.0/Distribution/Utils/0000755000000000000000000000000012627136220014707 5ustar0000000000000000Cabal-1.22.5.0/Distribution/Utils/NubList.hs0000644000000000000000000000660012627136220016625 0ustar0000000000000000{-# LANGUAGE CPP #-} module Distribution.Utils.NubList ( NubList -- opaque , toNubList -- smart construtor , fromNubList , overNubList , NubListR , toNubListR , fromNubListR , overNubListR ) where import Distribution.Compat.Binary #if __GLASGOW_HASKELL__ < 710 import Data.Monoid #endif import Distribution.Simple.Utils (ordNub, listUnion, ordNubRight, listUnionRight) import qualified Text.Read as R -- | NubList : A de-duplicated list that maintains the original order. newtype NubList a = NubList { fromNubList :: [a] } deriving Eq -- NubList assumes that nub retains the list order while removing duplicate -- elements (keeping the first occurence). Documentation for "Data.List.nub" -- does not specifically state that ordering is maintained so we will add a test -- for that to the test suite. -- | Smart constructor for the NubList type. toNubList :: Ord a => [a] -> NubList a toNubList list = NubList $ ordNub list -- | Lift a function over lists to a function over NubLists. overNubList :: Ord a => ([a] -> [a]) -> NubList a -> NubList a overNubList f (NubList list) = toNubList . f $ list -- | Monoid operations on NubLists. -- For a valid Monoid instance we need to satistfy the required monoid laws; -- identity, associativity and closure. -- -- Identity : by inspection: -- mempty `mappend` NubList xs == NubList xs `mappend` mempty -- -- Associativity : by inspection: -- (NubList xs `mappend` NubList ys) `mappend` NubList zs -- == NubList xs `mappend` (NubList ys `mappend` NubList zs) -- -- Closure : appending two lists of type a and removing duplicates obviously -- does not change the type. instance Ord a => Monoid (NubList a) where mempty = NubList [] mappend (NubList xs) (NubList ys) = NubList $ xs `listUnion` ys instance Show a => Show (NubList a) where show (NubList list) = show list instance (Ord a, Read a) => Read (NubList a) where readPrec = readNubList toNubList -- | Helper used by NubList/NubListR's Read instances. readNubList :: (Ord a, Read a) => ([a] -> l a) -> R.ReadPrec (l a) readNubList toList = R.parens . R.prec 10 $ fmap toList R.readPrec -- | Binary instance for 'NubList a' is the same as for '[a]'. For 'put', we -- just pull off constructor and put the list. For 'get', we get the list and -- make a 'NubList' out of it using 'toNubList'. instance (Ord a, Binary a) => Binary (NubList a) where put (NubList l) = put l get = fmap toNubList get -- | NubListR : A right-biased version of 'NubList'. That is @toNubListR -- ["-XNoFoo", "-XFoo", "-XNoFoo"]@ will result in @["-XFoo", "-XNoFoo"]@, -- unlike the normal 'NubList', which is left-biased. Built on top of -- 'ordNubRight' and 'listUnionRight'. newtype NubListR a = NubListR { fromNubListR :: [a] } deriving Eq -- | Smart constructor for the NubListR type. toNubListR :: Ord a => [a] -> NubListR a toNubListR list = NubListR $ ordNubRight list -- | Lift a function over lists to a function over NubListRs. overNubListR :: Ord a => ([a] -> [a]) -> NubListR a -> NubListR a overNubListR f (NubListR list) = toNubListR . f $ list instance Ord a => Monoid (NubListR a) where mempty = NubListR [] mappend (NubListR xs) (NubListR ys) = NubListR $ xs `listUnionRight` ys instance Show a => Show (NubListR a) where show (NubListR list) = show list instance (Ord a, Read a) => Read (NubListR a) where readPrec = readNubList toNubListR Cabal-1.22.5.0/doc/0000755000000000000000000000000012627136221011676 5ustar0000000000000000Cabal-1.22.5.0/doc/developing-packages.markdown0000644000000000000000000024253412627136221017364 0ustar0000000000000000% Cabal User Guide: Developing Cabal packages # Quickstart # Lets assume we have created a project directory and already have a Haskell module or two. Every project needs a name, we'll call this example "proglet". ~~~~~~~~~~~ $ cd proglet/ $ ls Proglet.hs ~~~~~~~~~~~ It is assumed that (apart from external dependencies) all the files that make up a package live under a common project root directory. This simple example has all the project files in one directory, but most packages will use one or more subdirectories. To turn this into a Cabal package we need two extra files in the project's root directory: * `proglet.cabal`: containing package metadata and build information. * `Setup.hs`: usually containing a few standardized lines of code, but can be customized if necessary. We can create both files manually or we can use `cabal init` to create them for us. ### Using "cabal init" ### The `cabal init` command is interactive. It asks us a number of questions starting with the package name and version. ~~~~~~~~~~ $ cabal init Package name [default "proglet"]? Package version [default "0.1"]? ... ~~~~~~~~~~ It also asks questions about various other bits of package metadata. For a package that you never intend to distribute to others, these fields can be left blank. One of the important questions is whether the package contains a library or an executable. Libraries are collections of Haskell modules that can be re-used by other Haskell libraries and programs, while executables are standalone programs. ~~~~~~~~~~ What does the package build: 1) Library 2) Executable Your choice? ~~~~~~~~~~ For the moment these are the only choices. For more complex packages (e.g. a library and multiple executables or test suites) the `.cabal` file can be edited afterwards. Finally, `cabal init` creates the initial `proglet.cabal` and `Setup.hs` files, and depending on your choice of license, a `LICENSE` file as well. ~~~~~~~~~~ Generating LICENSE... Generating Setup.hs... Generating proglet.cabal... You may want to edit the .cabal file and add a Description field. ~~~~~~~~~~ As this stage the `proglet.cabal` is not quite complete and before you are able to build the package you will need to edit the file and add some build information about the library or executable. ### Editing the .cabal file ### Load up the `.cabal` file in a text editor. The first part of the `.cabal` file has the package metadata and towards the end of the file you will find the `executable` or `library` section. You will see that the fields that have yet to be filled in are commented out. Cabal files use "`--`" Haskell-style comment syntax. (Note that comments are only allowed on lines on their own. Trailing comments on other lines are not allowed because they could be confused with program options.) If you selected earlier to create a library package then your `.cabal` file will have a section that looks like this: ~~~~~~~~~~~~~~~~~ library exposed-modules: Proglet -- other-modules: -- build-depends: ~~~~~~~~~~~~~~~~~ Alternatively, if you selected an executable then there will be a section like: ~~~~~~~~~~~~~~~~~ executable proglet -- main-is: -- other-modules: -- build-depends: ~~~~~~~~~~~~~~~~~ The build information fields listed (but commented out) are just the few most important and common fields. There are many others that are covered later in this chapter. Most of the build information fields are the same between libraries and executables. The difference is that libraries have a number of "exposed" modules that make up the public interface of the library, while executables have a file containing a `Main` module. The name of a library always matches the name of the package, so it is not specified in the library section. Executables often follow the name of the package too, but this is not required and the name is given explicitly. ### Modules included in the package ### For a library, `cabal init` looks in the project directory for files that look like Haskell modules and adds all the modules to the `exposed-modules` field. For modules that do not form part of your package's public interface, you can move those modules to the `other-modules` field. Either way, all modules in the library need to be listed. For an executable, `cabal init` does not try to guess which file contains your program's `Main` module. You will need to fill in the `main-is` field with the file name of your program's `Main` module (including `.hs` or `.lhs` extension). Other modules included in the executable should be listed in the `other-modules` field. ### Modules imported from other packages ### While your library or executable may include a number of modules, it almost certainly also imports a number of external modules from the standard libraries or other pre-packaged libraries. (These other libraries are of course just Cabal packages that contain a library.) You have to list all of the library packages that your library or executable imports modules from. Or to put it another way: you have to list all the other packages that your package depends on. For example, suppose the example `Proglet` module imports the module `Data.Map`. The `Data.Map` module comes from the `containers` package, so we must list it: ~~~~~~~~~~~~~~~~~ library exposed-modules: Proglet other-modules: build-depends: containers, base == 4.* ~~~~~~~~~~~~~~~~~ In addition, almost every package also depends on the `base` library package because it exports the standard `Prelude` module plus other basic modules like `Data.List`. You will notice that we have listed `base == 4.*`. This gives a constraint on the version of the base package that our package will work with. The most common kinds of constraints are: * `pkgname >= n` * `pkgname >= n && < m` * `pkgname == n.*` The last is just shorthand, for example `base == 4.*` means exactly the same thing as `base >= 4 && < 5`. ### Building the package ### For simple packages that's it! We can now try configuring and building the package: ~~~~~~~~~~~~~~~~ cabal configure cabal build ~~~~~~~~~~~~~~~~ Assuming those two steps worked then you can also install the package: ~~~~~~~~~~~~~~~~ cabal install ~~~~~~~~~~~~~~~~ For libraries this makes them available for use in GHCi or to be used by other packages. For executables it installs the program so that you can run it (though you may first need to adjust your system's `$PATH`). ### Next steps ### What we have covered so far should be enough for very simple packages that you use on your own system. The next few sections cover more details needed for more complex packages and details needed for distributing packages to other people. The previous chapter covers building and installing packages -- your own packages or ones developed by other people. # Package concepts # Before diving into the details of writing packages it helps to understand a bit about packages in the Haskell world and the particular approach that Cabal takes. ### The point of packages ### Packages are a mechanism for organising and distributing code. Packages are particularly suited for "programming in the large", that is building big systems by using and re-using code written by different people at different times. People organise code into packages based on functionality and dependencies. Social factors are also important: most packages have a single author, or a relatively small team of authors. Packages are also used for distribution: the idea is that a package can be created in one place and be moved to a different computer and be usable in that different environment. There are a surprising number of details that have to be got right for this to work, and a good package system helps to simply this process and make it reliable. Packages come in two main flavours: libraries of reusable code, and complete programs. Libraries present a code interface, an API, while programs can be run directly. In the Haskell world, library packages expose a set of Haskell modules as their public interface. Cabal packages can contain a library or executables or both. Some programming languages have packages as a builtin language concept. For example in Java, a package provides a local namespace for types and other definitions. In the Haskell world, packages are not a part of the language itself. Haskell programs consist of a number of modules, and packages just provide a way to partition the modules into sets of related functionality. Thus the choice of module names in Haskell is still important, even when using packages. ### Package names and versions ### All packages have a name, e.g. "HUnit". Package names are assumed to be unique. Cabal package names can use letters, numbers and hyphens, but not spaces. The namespace for Cabal packages is flat, not hierarchical. Packages also have a version, e.g "1.1". This matches the typical way in which packages are developed. Strictly speaking, each version of a package is independent, but usually they are very similar. Cabal package versions follow the conventional numeric style, consisting of a sequence of digits such as "1.0.1" or "2.0". There are a range of common conventions for "versioning" packages, that is giving some meaning to the version number in terms of changes in the package. Section [TODO] has some tips on package versioning. The combination of package name and version is called the _package ID_ and is written with a hyphen to separate the name and version, e.g. "HUnit-1.1". For Cabal packages, the combination of the package name and version _uniquely_ identifies each package. Or to put it another way: two packages with the same name and version are considered to _be_ the same. Strictly speaking, the package ID only identifies each Cabal _source_ package; the same Cabal source package can be configured and built in different ways. There is a separate installed package ID that uniquely identifies each installed package instance. Most of the time however, users need not be aware of this detail. ### Kinds of package: Cabal vs GHC vs system ### It can be slightly confusing at first because there are various different notions of package floating around. Fortunately the details are not very complicated. Cabal packages : Cabal packages are really source packages. That is they contain Haskell (and sometimes C) source code. Cabal packages can be compiled to produce GHC packages. They can also be translated into operating system packages. GHC packages : This is GHC's view on packages. GHC only cares about library packages, not executables. Library packages have to be registered with GHC for them to be available in GHCi or to be used when compiling other programs or packages. The low-level tool `ghc-pkg` is used to register GHC packages and to get information on what packages are currently registered. You never need to make GHC packages manually. When you build and install a Cabal package containing a library then it gets registered with GHC automatically. Haskell implementations other than GHC have essentially the same concept of registered packages. For the most part, Cabal hides the slight differences. Operating system packages : On operating systems like Linux and Mac OS X, the system has a specific notion of a package and there are tools for installing and managing packages. The Cabal package format is designed to allow Cabal packages to be translated, mostly-automatically, into operating system packages. They are usually translated 1:1, that is a single Cabal package becomes a single system package. It is also possible to make Windows installers from Cabal packages, though this is typically done for a program together with all of its library dependencies, rather than packaging each library separately. ### Unit of distribution ### The Cabal package is the unit of distribution. What this means is that each Cabal package can be distributed on its own in source or binary form. Of course there may dependencies between packages, but there is usually a degree of flexibility in which versions of packages can work together so distributing them independently makes sense. It is perhaps easiest to see what being ``the unit of distribution'' means by contrast to an alternative approach. Many projects are made up of several interdependent packages and during development these might all be kept under one common directory tree and be built and tested together. When it comes to distribution however, rather than distributing them all together in a single tarball, it is required that they each be distributed independently in their own tarballs. Cabal's approach is to say that if you can specify a dependency on a package then that package should be able to be distributed independently. Or to put it the other way round, if you want to distribute it as a single unit, then it should be a single package. ### Explicit dependencies and automatic package management ### Cabal takes the approach that all packages dependencies are specified explicitly and specified in a declarative way. The point is to enable automatic package management. This means tools like `cabal` can resolve dependencies and install a package plus all of its dependencies automatically. Alternatively, it is possible to mechanically (or mostly mechanically) translate Cabal packages into system packages and let the system package manager install dependencies automatically. It is important to track dependencies accurately so that packages can reliably be moved from one system to another system and still be able to build it there. Cabal is therefore relatively strict about specifying dependencies. For example Cabal's default build system will not even let code build if it tries to import a module from a package that isn't listed in the `.cabal` file, even if that package is actually installed. This helps to ensure that there are no "untracked dependencies" that could cause the code to fail to build on some other system. The explicit dependency approach is in contrast to the traditional "./configure" approach where instead of specifying dependencies declaratively, the `./configure` script checks if the dependencies are present on the system. Some manual work is required to transform a `./configure` based package into a Linux distribution package (or similar). This conversion work is usually done by people other than the package author(s). The practical effect of this is that only the most popular packages will benefit from automatic package management. Instead, Cabal forces the original author to specify the dependencies but the advantage is that every package can benefit from automatic package management. The "./configure" approach tends to encourage packages that adapt themselves to the environment in which they are built, for example by disabling optional features so that they can continue to work when a particular dependency is not available. This approach makes sense in a world where installing additional dependencies is a tiresome manual process and so minimising dependencies is important. The automatic package management view is that packages should just declare what they need and the package manager will take responsibility for ensuring that all the dependencies are installed. Sometimes of course optional features and optional dependencies do make sense. Cabal packages can have optional features and varying dependencies. These conditional dependencies are still specified in a declarative way however and remain compatible with automatic package management. The need to remain compatible with automatic package management means that Cabal's conditional dependencies system is a bit less flexible than with the "./configure" approach. ### Portability ### One of the purposes of Cabal is to make it easier to build packages on different platforms (operating systems and CPU architectures), with different compiler versions and indeed even with different Haskell implementations. (Yes, there are Haskell implementations other than GHC!) Cabal provides abstractions of features present in different Haskell implementations and wherever possible it is best to take advantage of these to increase portability. Where necessary however it is possible to use specific features of specific implementations. For example a package author can list in the package's `.cabal` what language extensions the code uses. This allows Cabal to figure out if the language extension is supported by the Haskell implementation that the user picks. Additionally, certain language extensions such as Template Haskell require special handling from the build system and by listing the extension it provides the build system with enough information to do the right thing. Another similar example is linking with foreign libraries. Rather than specifying GHC flags directly, the package author can list the libraries that are needed and the build system will take care of using the right flags for the compiler. Additionally this makes it easier for tools to discover what system C libraries a package needs, which is useful for tracking dependencies on system libraries (e.g. when translating into Linux distribution packages). In fact both of these examples fall into the category of explicitly specifying dependencies. Not all dependencies are other Cabal packages. Foreign libraries are clearly another kind of dependency. It's also possible to think of language extensions as dependencies: the package depends on a Haskell implementation that supports all those extensions. Where compiler-specific options are needed however, there is an "escape hatch" available. The developer can specify implementation-specific options and more generally there is a configuration mechanism to customise many aspects of how a package is built depending on the Haskell implementation, the operating system, computer architecture and user-specified configuration flags. # Developing packages # The Cabal package is the unit of distribution. When installed, its purpose is to make available: * One or more Haskell programs. * At most one library, exposing a number of Haskell modules. However having both a library and executables in a package does not work very well; if the executables depend on the library, they must explicitly list all the modules they directly or indirectly import from that library. Fortunately, starting with Cabal 1.8.0.4, executables can also declare the package that they are in as a dependency, and Cabal will treat them as if they were in another package that depended on the library. Internally, the package may consist of much more than a bunch of Haskell modules: it may also have C source code and header files, source code meant for preprocessing, documentation, test cases, auxiliary tools etc. A package is identified by a globally-unique _package name_, which consists of one or more alphanumeric words separated by hyphens. To avoid ambiguity, each of these words should contain at least one letter. Chaos will result if two distinct packages with the same name are installed on the same system. A particular version of the package is distinguished by a _version number_, consisting of a sequence of one or more integers separated by dots. These can be combined to form a single text string called the _package ID_, using a hyphen to separate the name from the version, e.g. "`HUnit-1.1`". Note: Packages are not part of the Haskell language; they simply populate the hierarchical space of module names. In GHC 6.6 and later a program may contain multiple modules with the same name if they come from separate packages; in all other current Haskell systems packages may not overlap in the modules they provide, including hidden modules. ## Creating a package ## Suppose you have a directory hierarchy containing the source files that make up your package. You will need to add two more files to the root directory of the package: _package_`.cabal` : a Unicode UTF-8 text file containing a package description. For details of the syntax of this file, see the [section on package descriptions](#package-descriptions). `Setup.hs` : a single-module Haskell program to perform various setup tasks (with the interface described in the section on [building and installing packages](installing-packages.html). This module should import only modules that will be present in all Haskell implementations, including modules of the Cabal library. The content of this file is determined by the `build-type` setting in the `.cabal` file. In most cases it will be trivial, calling on the Cabal library to do most of the work. Once you have these, you can create a source bundle of this directory for distribution. Building of the package is discussed in the section on [building and installing packages](installing-packages.html). One of the purposes of Cabal is to make it easier to build a package with different Haskell implementations. So it provides abstractions of features present in different Haskell implementations and wherever possible it is best to take advantage of these to increase portability. Where necessary however it is possible to use specific features of specific implementations. For example one of the pieces of information a package author can put in the package's `.cabal` file is what language extensions the code uses. This is far preferable to specifying flags for a specific compiler as it allows Cabal to pick the right flags for the Haskell implementation that the user picks. It also allows Cabal to figure out if the language extension is even supported by the Haskell implementation that the user picks. Where compiler-specific options are needed however, there is an "escape hatch" available. The developer can specify implementation-specific options and more generally there is a configuration mechanism to customise many aspects of how a package is built depending on the Haskell implementation, the Operating system, computer architecture and user-specified configuration flags. ~~~~~~~~~~~~~~~~ name: Foo version: 1.0 library build-depends: base exposed-modules: Foo extensions: ForeignFunctionInterface ghc-options: -Wall if os(windows) build-depends: Win32 ~~~~~~~~~~~~~~~~ #### Example: A package containing a simple library #### The HUnit package contains a file `HUnit.cabal` containing: ~~~~~~~~~~~~~~~~ name: HUnit version: 1.1.1 synopsis: A unit testing framework for Haskell homepage: http://hunit.sourceforge.net/ category: Testing author: Dean Herington license: BSD3 license-file: LICENSE cabal-version: >= 1.10 build-type: Simple library build-depends: base >= 2 && < 4 exposed-modules: Test.HUnit.Base, Test.HUnit.Lang, Test.HUnit.Terminal, Test.HUnit.Text, Test.HUnit default-extensions: CPP ~~~~~~~~~~~~~~~~ and the following `Setup.hs`: ~~~~~~~~~~~~~~~~ import Distribution.Simple main = defaultMain ~~~~~~~~~~~~~~~~ #### Example: A package containing executable programs #### ~~~~~~~~~~~~~~~~ name: TestPackage version: 0.0 synopsis: Small package with two programs author: Angela Author license: BSD3 build-type: Simple cabal-version: >= 1.2 executable program1 build-depends: HUnit main-is: Main.hs hs-source-dirs: prog1 executable program2 main-is: Main.hs build-depends: HUnit hs-source-dirs: prog2 other-modules: Utils ~~~~~~~~~~~~~~~~ with `Setup.hs` the same as above. #### Example: A package containing a library and executable programs #### ~~~~~~~~~~~~~~~~ name: TestPackage version: 0.0 synopsis: Package with library and two programs license: BSD3 author: Angela Author build-type: Simple cabal-version: >= 1.2 library build-depends: HUnit exposed-modules: A, B, C executable program1 main-is: Main.hs hs-source-dirs: prog1 other-modules: A, B executable program2 main-is: Main.hs hs-source-dirs: prog2 other-modules: A, C, Utils ~~~~~~~~~~~~~~~~ with `Setup.hs` the same as above. Note that any library modules required (directly or indirectly) by an executable must be listed again. The trivial setup script used in these examples uses the _simple build infrastructure_ provided by the Cabal library (see [Distribution.Simple][dist-simple]). The simplicity lies in its interface rather that its implementation. It automatically handles preprocessing with standard preprocessors, and builds packages for all the Haskell implementations. The simple build infrastructure can also handle packages where building is governed by system-dependent parameters, if you specify a little more (see the section on [system-dependent parameters](#system-dependent-parameters)). A few packages require [more elaborate solutions](#more-complex-packages). ## Package descriptions ## The package description file must have a name ending in "`.cabal`". It must be a Unicode text file encoded using valid UTF-8. There must be exactly one such file in the directory. The first part of the name is usually the package name, and some of the tools that operate on Cabal packages require this. In the package description file, lines whose first non-whitespace characters are "`--`" are treated as comments and ignored. This file should contain of a number global property descriptions and several sections. * The [global properties](#package-properties) describe the package as a whole, such as name, license, author, etc. * Optionally, a number of _configuration flags_ can be declared. These can be used to enable or disable certain features of a package. (see the section on [configurations](#configurations)). * The (optional) library section specifies the [library properties](#library) and relevant [build information](#build-information). * Following is an arbitrary number of executable sections which describe an executable program and relevant [build information](#build-information). Each section consists of a number of property descriptions in the form of field/value pairs, with a syntax roughly like mail message headers. * Case is not significant in field names, but is significant in field values. * To continue a field value, indent the next line relative to the field name. * Field names may be indented, but all field values in the same section must use the same indentation. * Tabs are *not* allowed as indentation characters due to a missing standard interpretation of tab width. * To get a blank line in a field value, use an indented "`.`" The syntax of the value depends on the field. Field types include: _token_, _filename_, _directory_ : Either a sequence of one or more non-space non-comma characters, or a quoted string in Haskell 98 lexical syntax. Unless otherwise stated, relative filenames and directories are interpreted from the package root directory. _freeform_, _URL_, _address_ : An arbitrary, uninterpreted string. _identifier_ : A letter followed by zero or more alphanumerics or underscores. _compiler_ : A compiler flavor (one of: `GHC`, `JHC`, `UHC` or `LHC`) followed by a version range. For example, `GHC ==6.10.3`, or `LHC >=0.6 && <0.8`. ### Modules and preprocessors ### Haskell module names listed in the `exposed-modules` and `other-modules` fields may correspond to Haskell source files, i.e. with names ending in "`.hs`" or "`.lhs`", or to inputs for various Haskell preprocessors. The simple build infrastructure understands the extensions: * `.gc` ([greencard][]) * `.chs` ([c2hs][]) * `.hsc` (`hsc2hs`) * `.y` and `.ly` ([happy][]) * `.x` ([alex][]) * `.cpphs` ([cpphs][]) When building, Cabal will automatically run the appropriate preprocessor and compile the Haskell module it produces. Some fields take lists of values, which are optionally separated by commas, except for the `build-depends` field, where the commas are mandatory. Some fields are marked as required. All others are optional, and unless otherwise specified have empty default values. ### Package properties ### These fields may occur in the first top-level properties section and describe the package as a whole: `name:` _package-name_ (required) : The unique name of the package, without the version number. `version:` _numbers_ (required) : The package version number, usually consisting of a sequence of natural numbers separated by dots. `cabal-version:` _>= x.y_ : The version of the Cabal specification that this package description uses. The Cabal specification does slowly evolve, introducing new features and occasionally changing the meaning of existing features. By specifying which version of the spec you are using it enables programs which process the package description to know what syntax to expect and what each part means. For historical reasons this is always expressed using _>=_ version range syntax. No other kinds of version range make sense, in particular upper bounds do not make sense. In future this field will specify just a version number, rather than a version range. The version number you specify will affect both compatibility and behaviour. Most tools (including the Cabal library and cabal program) understand a range of versions of the Cabal specification. Older tools will of course only work with older versions of the Cabal specification. Most of the time, tools that are too old will recognise this fact and produce a suitable error message. As for behaviour, new versions of the Cabal spec can change the meaning of existing syntax. This means if you want to take advantage of the new meaning or behaviour then you must specify the newer Cabal version. Tools are expected to use the meaning and behaviour appropriate to the version given in the package description. In particular, the syntax of package descriptions changed significantly with Cabal version 1.2 and the `cabal-version` field is now required. Files written in the old syntax are still recognized, so if you require compatibility with very old Cabal versions then you may write your package description file using the old syntax. Please consult the user's guide of an older Cabal version for a description of that syntax. `build-type:` _identifier_ : The type of build used by this package. Build types are the constructors of the [BuildType][] type, defaulting to `Custom`. If the build type is anything other than `Custom`, then the `Setup.hs` file *must* be exactly the standardized content discussed below. This is because in these cases, `cabal` will ignore the `Setup.hs` file completely, whereas other methods of package management, such as `runhaskell Setup.hs [CMD]`, still rely on the `Setup.hs` file. For build type `Simple`, the contents of `Setup.hs` must be: ~~~~~~~~~~~~~~~~ import Distribution.Simple main = defaultMain ~~~~~~~~~~~~~~~~ For build type `Configure` (see the section on [system-dependent parameters](#system-dependent-parameters) below), the contents of `Setup.hs` must be: ~~~~~~~~~~~~~~~~ import Distribution.Simple main = defaultMainWithHooks autoconfUserHooks ~~~~~~~~~~~~~~~~ For build type `Make` (see the section on [more complex packages](installing-packages.html#more-complex-packages) below), the contents of `Setup.hs` must be: ~~~~~~~~~~~~~~~~ import Distribution.Make main = defaultMain ~~~~~~~~~~~~~~~~ For build type `Custom`, the file `Setup.hs` can be customized, and will be used both by `cabal` and other tools. For most packages, the build type `Simple` is sufficient. `license:` _identifier_ (default: `AllRightsReserved`) : The type of license under which this package is distributed. License names are the constants of the [License][dist-license] type. `license-file:` _filename_ or `license-files:` _filename list_ : The name of a file(s) containing the precise copyright license for this package. The license file(s) will be installed with the package. If you have multiple license files then use the `license-files` field instead of (or in addition to) the `license-file` field. `copyright:` _freeform_ : The content of a copyright notice, typically the name of the holder of the copyright on the package and the year(s) from which copyright is claimed. For example: `Copyright: (c) 2006-2007 Joe Bloggs` `author:` _freeform_ : The original author of the package. Remember that `.cabal` files are Unicode, using the UTF-8 encoding. `maintainer:` _address_ : The current maintainer or maintainers of the package. This is an e-mail address to which users should send bug reports, feature requests and patches. `stability:` _freeform_ : The stability level of the package, e.g. `alpha`, `experimental`, `provisional`, `stable`. `homepage:` _URL_ : The package homepage. `bug-reports:` _URL_ : The URL where users should direct bug reports. This would normally be either: * A `mailto:` URL, e.g. for a person or a mailing list. * An `http:` (or `https:`) URL for an online bug tracking system. For example Cabal itself uses a web-based bug tracking system ~~~~~~~~~~~~~~~~ bug-reports: http://hackage.haskell.org/trac/hackage/ ~~~~~~~~~~~~~~~~ `package-url:` _URL_ : The location of a source bundle for the package. The distribution should be a Cabal package. `synopsis:` _freeform_ : A very short description of the package, for use in a table of packages. This is your headline, so keep it short (one line) but as informative as possible. Save space by not including the package name or saying it's written in Haskell. `description:` _freeform_ : Description of the package. This may be several paragraphs, and should be aimed at a Haskell programmer who has never heard of your package before. For library packages, this field is used as prologue text by [`setup haddock`](installing-packages.html#setup-haddock), and thus may contain the same markup as [haddock][] documentation comments. `category:` _freeform_ : A classification category for future use by the package catalogue [Hackage]. These categories have not yet been specified, but the upper levels of the module hierarchy make a good start. `tested-with:` _compiler list_ : A list of compilers and versions against which the package has been tested (or at least built). `data-files:` _filename list_ : A list of files to be installed for run-time use by the package. This is useful for packages that use a large amount of static data, such as tables of values or code templates. Cabal provides a way to [find these files at run-time](#accessing-data-files-from-package-code). A limited form of `*` wildcards in file names, for example `data-files: images/*.png` matches all the `.png` files in the `images` directory. The limitation is that `*` wildcards are only allowed in place of the file name, not in the directory name or file extension. In particular, wildcards do not include directories contents recursively. Furthermore, if a wildcard is used it must be used with an extension, so `data-files: data/*` is not allowed. When matching a wildcard plus extension, a file's full extension must match exactly, so `*.gz` matches `foo.gz` but not `foo.tar.gz`. A wildcard that does not match any files is an error. The reason for providing only a very limited form of wildcard is to concisely express the common case of a large number of related files of the same file type without making it too easy to accidentally include unwanted files. `data-dir:` _directory_ : The directory where Cabal looks for data files to install, relative to the source directory. By default, Cabal will look in the source directory itself. `extra-source-files:` _filename list_ : A list of additional files to be included in source distributions built with [`setup sdist`](installing-packages.html#setup-sdist). As with `data-files` it can use a limited form of `*` wildcards in file names. `extra-doc-files:` _filename list_ : A list of additional files to be included in source distributions, and also copied to the html directory when Haddock documentation is generated. As with `data-files` it can use a limited form of `*` wildcards in file names. `extra-tmp-files:` _filename list_ : A list of additional files or directories to be removed by [`setup clean`](installing-packages.html#setup-clean). These would typically be additional files created by additional hooks, such as the scheme described in the section on [system-dependent parameters](#system-dependent-parameters). ### Library ### The library section should contain the following fields: `exposed-modules:` _identifier list_ (required if this package contains a library) : A list of modules added by this package. `exposed:` _boolean_ (default: `True`) : Some Haskell compilers (notably GHC) support the notion of packages being "exposed" or "hidden" which means the modules they provide can be easily imported without always having to specify which package they come from. However this only works effectively if the modules provided by all exposed packages do not overlap (otherwise a module import would be ambiguous). Almost all new libraries use hierarchical module names that do not clash, so it is very uncommon to have to use this field. However it may be necessary to set `exposed: False` for some old libraries that use a flat module namespace or where it is known that the exposed modules would clash with other common modules. `reexported-modules:` _exportlist _ : Supported only in GHC 7.10 and later. A list of modules to _reexport_ from this package. The syntax of this field is `orig-pkg:Name as NewName` to reexport module `Name` from `orig-pkg` with the new name `NewName`. We also support abbreviated versions of the syntax: if you omit `as NewName`, we'll reexport without renaming; if you omit `orig-pkg`, then we will automatically figure out which package to reexport from, if it's unambiguous. Reexported modules are useful for compatibility shims when a package has been split into multiple packages, and they have the useful property that if a package provides a module, and another package reexports it under the same name, these are not considered a conflict (as would be the case with a stub module.) They can also be used to resolve name conflicts. The library section may also contain build information fields (see the section on [build information](#build-information)). #### Opening an interpreter session #### While developing a package, it is often useful to make its code available inside an interpreter session. This can be done with the `repl` command: ~~~~~~~~~~~~~~~~ cabal repl ~~~~~~~~~~~~~~~~ The name comes from the acronym [REPL], which stands for "read-eval-print-loop". By default `cabal repl` loads the first component in a package. If the package contains several named components, the name can be given as an argument to `repl`. The name can be also optionally prefixed with the component's type for disambiguation purposes. Example: ~~~~~~~~~~~~~~~~ cabal repl foo cabal repl exe:foo cabal repl test:bar cabal repl bench:baz ~~~~~~~~~~~~~~~~ #### Freezing dependency versions #### If a package is built in several different environments, such as a development environment, a staging environment and a production environment, it may be necessary or desirable to ensure that the same dependency versions are selected in each environment. This can be done with the `freeze` command: ~~~~~~~~~~~~~~~~ cabal freeze ~~~~~~~~~~~~~~~~ The command writes the selected version for all dependencies to the `cabal.config` file. All environments which share this file will use the dependency versions specified in it. ### Executables ### Executable sections (if present) describe executable programs contained in the package and must have an argument after the section label, which defines the name of the executable. This is a freeform argument but may not contain spaces. The executable may be described using the following fields, as well as build information fields (see the section on [build information](#build-information)). `main-is:` _filename_ (required) : The name of the `.hs` or `.lhs` file containing the `Main` module. Note that it is the `.hs` filename that must be listed, even if that file is generated using a preprocessor. The source file must be relative to one of the directories listed in `hs-source-dirs`. #### Running executables #### You can have Cabal build and run your executables by using the `run` command: ~~~~~~~~~~~~~~~~ $ cabal run EXECUTABLE [-- EXECUTABLE_FLAGS] ~~~~~~~~~~~~~~~~ This command will configure, build and run the executable `EXECUTABLE`. The double dash separator is required to distinguish executable flags from `run`'s own flags. If there is only one executable defined in the whole package, the executable's name can be omitted. See the output of `cabal help run` for a list of options you can pass to `cabal run`. ### Test suites ### Test suite sections (if present) describe package test suites and must have an argument after the section label, which defines the name of the test suite. This is a freeform argument, but may not contain spaces. It should be unique among the names of the package's other test suites, the package's executables, and the package itself. Using test suite sections requires at least Cabal version 1.9.2. The test suite may be described using the following fields, as well as build information fields (see the section on [build information](#build-information)). `type:` _interface_ (required) : The interface type and version of the test suite. Cabal supports two test suite interfaces, called `exitcode-stdio-1.0` and `detailed-0.9`. Each of these types may require or disallow other fields as described below. Test suites using the `exitcode-stdio-1.0` interface are executables that indicate test failure with a non-zero exit code when run; they may provide human-readable log information through the standard output and error channels. This interface is provided primarily for compatibility with existing test suites; it is preferred that new test suites be written for the `detailed-0.9` interface. The `exitcode-stdio-1.0` type requires the `main-is` field. `main-is:` _filename_ (required: `exitcode-stdio-1.0`, disallowed: `detailed-0.9`) : The name of the `.hs` or `.lhs` file containing the `Main` module. Note that it is the `.hs` filename that must be listed, even if that file is generated using a preprocessor. The source file must be relative to one of the directories listed in `hs-source-dirs`. This field is analogous to the `main-is` field of an executable section. Test suites using the `detailed-0.9` interface are modules exporting the symbol `tests :: IO [Test]`. The `Test` type is exported by the module `Distribution.TestSuite` provided by Cabal. For more details, see the example below. The `detailed-0.9` interface allows Cabal and other test agents to inspect a test suite's results case by case, producing detailed human- and machine-readable log files. The `detailed-0.9` interface requires the `test-module` field. `test-module:` _identifier_ (required: `detailed-0.9`, disallowed: `exitcode-stdio-1.0`) : The module exporting the `tests` symbol. #### Example: Package using `exitcode-stdio-1.0` interface #### The example package description and executable source file below demonstrate the use of the `exitcode-stdio-1.0` interface. For brevity, the example package does not include a library or any normal executables, but a real package would be required to have at least one library or executable. foo.cabal: ~~~~~~~~~~~~~~~~ Name: foo Version: 1.0 License: BSD3 Cabal-Version: >= 1.9.2 Build-Type: Simple Test-Suite test-foo type: exitcode-stdio-1.0 main-is: test-foo.hs build-depends: base ~~~~~~~~~~~~~~~~ test-foo.hs: ~~~~~~~~~~~~~~~~ module Main where import System.Exit (exitFailure) main = do putStrLn "This test always fails!" exitFailure ~~~~~~~~~~~~~~~~ #### Example: Package using `detailed-0.9` interface #### The example package description and test module source file below demonstrate the use of the `detailed-0.9` interface. For brevity, the example package does note include a library or any normal executables, but a real package would be required to have at least one library or executable. The test module below also develops a simple implementation of the interface set by `Distribution.TestSuite`, but in actual usage the implementation would be provided by the library that provides the testing facility. bar.cabal: ~~~~~~~~~~~~~~~~ Name: bar Version: 1.0 License: BSD3 Cabal-Version: >= 1.9.2 Build-Type: Simple Test-Suite test-bar type: detailed-0.9 test-module: Bar build-depends: base, Cabal >= 1.9.2 ~~~~~~~~~~~~~~~~ Bar.hs: ~~~~~~~~~~~~~~~~ module Bar ( tests ) where import Distribution.TestSuite tests :: IO [Test] tests = return [ Test succeeds, Test fails ] where succeeds = TestInstance { run = return $ Finished Pass , name = "succeeds" , tags = [] , options = [] , setOption = \_ _ -> Right succeeds } fails = TestInstance { run = return $ Finished $ Fail "Always fails!" , name = "fails" , tags = [] , options = [] , setOption = \_ _ -> Right fails } ~~~~~~~~~~~~~~~~ #### Running test suites #### You can have Cabal run your test suites using its built-in test runner: ~~~~~~~~~~~~~~~~ $ cabal configure --enable-tests $ cabal build $ cabal test ~~~~~~~~~~~~~~~~ See the output of `cabal help test` for a list of options you can pass to `cabal test`. ### Benchmarks ### Benchmark sections (if present) describe benchmarks contained in the package and must have an argument after the section label, which defines the name of the benchmark. This is a freeform argument, but may not contain spaces. It should be unique among the names of the package's other benchmarks, the package's test suites, the package's executables, and the package itself. Using benchmark sections requires at least Cabal version 1.9.2. The benchmark may be described using the following fields, as well as build information fields (see the section on [build information](#build-information)). `type:` _interface_ (required) : The interface type and version of the benchmark. At the moment Cabal only support one benchmark interface, called `exitcode-stdio-1.0`. Benchmarks using the `exitcode-stdio-1.0` interface are executables that indicate failure to run the benchmark with a non-zero exit code when run; they may provide human-readable information through the standard output and error channels. `main-is:` _filename_ (required: `exitcode-stdio-1.0`) : The name of the `.hs` or `.lhs` file containing the `Main` module. Note that it is the `.hs` filename that must be listed, even if that file is generated using a preprocessor. The source file must be relative to one of the directories listed in `hs-source-dirs`. This field is analogous to the `main-is` field of an executable section. #### Example: Package using `exitcode-stdio-1.0` interface #### The example package description and executable source file below demonstrate the use of the `exitcode-stdio-1.0` interface. For brevity, the example package does not include a library or any normal executables, but a real package would be required to have at least one library or executable. foo.cabal: ~~~~~~~~~~~~~~~~ Name: foo Version: 1.0 License: BSD3 Cabal-Version: >= 1.9.2 Build-Type: Simple Benchmark bench-foo type: exitcode-stdio-1.0 main-is: bench-foo.hs build-depends: base, time ~~~~~~~~~~~~~~~~ bench-foo.hs: ~~~~~~~~~~~~~~~~ {-# LANGUAGE BangPatterns #-} module Main where import Data.Time.Clock fib 0 = 1 fib 1 = 1 fib n = fib (n-1) + fib (n-2) main = do start <- getCurrentTime let !r = fib 20 end <- getCurrentTime putStrLn $ "fib 20 took " ++ show (diffUTCTime end start) ~~~~~~~~~~~~~~~~ #### Running benchmarks #### You can have Cabal run your benchmark using its built-in benchmark runner: ~~~~~~~~~~~~~~~~ $ cabal configure --enable-benchmarks $ cabal build $ cabal bench ~~~~~~~~~~~~~~~~ See the output of `cabal help bench` for a list of options you can pass to `cabal bench`. ### Build information ### The following fields may be optionally present in a library or executable section, and give information for the building of the corresponding library or executable. See also the sections on [system-dependent parameters](#system-dependent-parameters) and [configurations](#configurations) for a way to supply system-dependent values for these fields. `build-depends:` _package list_ : A list of packages needed to build this one. Each package can be annotated with a version constraint. Version constraints use the operators `==, >=, >, <, <=` and a version number. Multiple constraints can be combined using `&&` or `||`. If no version constraint is specified, any version is assumed to be acceptable. For example: ~~~~~~~~~~~~~~~~ library build-depends: base >= 2, foo >= 1.2 && < 1.3, bar ~~~~~~~~~~~~~~~~ Dependencies like `foo >= 1.2 && < 1.3` turn out to be very common because it is recommended practise for package versions to correspond to API versions. As of Cabal 1.6, there is a special syntax to support this use: ~~~~~~~~~~~~~~~~ build-depends: foo ==1.2.* ~~~~~~~~~~~~~~~~ It is only syntactic sugar. It is exactly equivalent to `foo >= 1.2 && < 1.3`. With Cabal 1.20 and GHC 7.10, `build-depends` also supports module thinning and renaming, which allows you to selectively decide what modules become visible from a package dependency. For example: ~~~~~~~~~~~~~~~~ build-depends: containers (Data.Set, Data.IntMap as Map) ~~~~~~~~~~~~~~~~ This results in only the modules `Data.Set` and `Map` being visible to the user from containers, hiding all other modules. To add additional names for modules without hiding the others, you can use the `with` keyword: ~~~~~~~~~~~~~~~~ build-depends: containers with (Data.IntMap as Map) ~~~~~~~~~~~~~~~~ Note: Prior to Cabal 1.8, build-depends specified in each section were global to all sections. This was unintentional, but some packages were written to depend on it, so if you need your build-depends to be local to each section, you must specify at least `Cabal-Version: >= 1.8` in your `.cabal` file. `other-modules:` _identifier list_ : A list of modules used by the component but not exposed to users. For a library component, these would be hidden modules of the library. For an executable, these would be auxiliary modules to be linked with the file named in the `main-is` field. Note: Every module in the package *must* be listed in one of `other-modules`, `exposed-modules` or `main-is` fields. `hs-source-dirs:` _directory list_ (default: "`.`") : Root directories for the module hierarchy. For backwards compatibility, the old variant `hs-source-dir` is also recognized. `extensions:` _identifier list_ : A list of Haskell extensions used by every module. Extension names are the constructors of the [Extension][extension] type. These determine corresponding compiler options. In particular, `CPP` specifies that Haskell source files are to be preprocessed with a C preprocessor. Extensions used only by one module may be specified by placing a `LANGUAGE` pragma in the source file affected, e.g.: ~~~~~~~~~~~~~~~~ {-# LANGUAGE CPP, MultiParamTypeClasses #-} ~~~~~~~~~~~~~~~~ Note: GHC versions prior to 6.6 do not support the `LANGUAGE` pragma. `build-tools:` _program list_ : A list of programs, possibly annotated with versions, needed to build this package, e.g. `c2hs >= 0.15, cpphs`.If no version constraint is specified, any version is assumed to be acceptable. `buildable:` _boolean_ (default: `True`) : Is the component buildable? Like some of the other fields below, this field is more useful with the slightly more elaborate form of the simple build infrastructure described in the section on [system-dependent parameters](#system-dependent-parameters). `ghc-options:` _token list_ : Additional options for GHC. You can often achieve the same effect using the `extensions` field, which is preferred. Options required only by one module may be specified by placing an `OPTIONS_GHC` pragma in the source file affected. `ghc-prof-options:` _token list_ : Additional options for GHC when the package is built with profiling enabled. `ghc-shared-options:` _token list_ : Additional options for GHC when the package is built as shared library. `includes:` _filename list_ : A list of header files to be included in any compilations via C. This field applies to both header files that are already installed on the system and to those coming with the package to be installed. These files typically contain function prototypes for foreign imports used by the package. `install-includes:` _filename list_ : A list of header files from this package to be installed into `$libdir/includes` when the package is installed. Files listed in `install-includes:` should be found in relative to the top of the source tree or relative to one of the directories listed in `include-dirs`. `install-includes` is typically used to name header files that contain prototypes for foreign imports used in Haskell code in this package, for which the C implementations are also provided with the package. Note that to include them when compiling the package itself, they need to be listed in the `includes:` field as well. `include-dirs:` _directory list_ : A list of directories to search for header files, when preprocessing with `c2hs`, `hsc2hs`, `cpphs` or the C preprocessor, and also when compiling via C. `c-sources:` _filename list_ : A list of C source files to be compiled and linked with the Haskell files. `js-sources:` _filename list_ : A list of JavaScript source files to be linked with the Haskell files (only for JavaScript targets). `extra-libraries:` _token list_ : A list of extra libraries to link with. `extra-ghci-libraries:` _token list_ : A list of extra libraries to be used instead of 'extra-libraries' when the package is loaded with GHCi. `extra-lib-dirs:` _directory list_ : A list of directories to search for libraries. `cc-options:` _token list_ : Command-line arguments to be passed to the C compiler. Since the arguments are compiler-dependent, this field is more useful with the setup described in the section on [system-dependent parameters](#system-dependent-parameters). `cpp-options:` _token list_ : Command-line arguments for pre-processing Haskell code. Applies to haskell source and other pre-processed Haskell source like .hsc .chs. Does not apply to C code, that's what cc-options is for. `ld-options:` _token list_ : Command-line arguments to be passed to the linker. Since the arguments are compiler-dependent, this field is more useful with the setup described in the section on [system-dependent parameters](#system-dependent-parameters)>. `pkgconfig-depends:` _package list_ : A list of [pkg-config][] packages, needed to build this package. They can be annotated with versions, e.g. `gtk+-2.0 >= 2.10, cairo >= 1.0`. If no version constraint is specified, any version is assumed to be acceptable. Cabal uses `pkg-config` to find if the packages are available on the system and to find the extra compilation and linker options needed to use the packages. If you need to bind to a C library that supports `pkg-config` (use `pkg-config --list-all` to find out if it is supported) then it is much preferable to use this field rather than hard code options into the other fields. `frameworks:` _token list_ : On Darwin/MacOS X, a list of frameworks to link to. See Apple's developer documentation for more details on frameworks. This entry is ignored on all other platforms. ### Configurations ### Library and executable sections may include conditional blocks, which test for various system parameters and configuration flags. The flags mechanism is rather generic, but most of the time a flag represents certain feature, that can be switched on or off by the package user. Here is an example package description file using configurations: #### Example: A package containing a library and executable programs #### ~~~~~~~~~~~~~~~~ Name: Test1 Version: 0.0.1 Cabal-Version: >= 1.2 License: BSD3 Author: Jane Doe Synopsis: Test package to test configurations Category: Example Flag Debug Description: Enable debug support Default: False Flag WebFrontend Description: Include API for web frontend. -- Cabal checks if the configuration is possible, first -- with this flag set to True and if not it tries with False Library Build-Depends: base Exposed-Modules: Testing.Test1 Extensions: CPP if flag(debug) GHC-Options: -DDEBUG if !os(windows) CC-Options: "-DDEBUG" else CC-Options: "-DNDEBUG" if flag(webfrontend) Build-Depends: cgi > 0.42 Other-Modules: Testing.WebStuff Executable test1 Main-is: T1.hs Other-Modules: Testing.Test1 Build-Depends: base if flag(debug) CC-Options: "-DDEBUG" GHC-Options: -DDEBUG ~~~~~~~~~~~~~~~~ #### Layout #### Flags, conditionals, library and executable sections use layout to indicate structure. This is very similar to the Haskell layout rule. Entries in a section have to all be indented to the same level which must be more than the section header. Tabs are not allowed to be used for indentation. As an alternative to using layout you can also use explicit braces `{}`. In this case the indentation of entries in a section does not matter, though different fields within a block must be on different lines. Here is a bit of the above example again, using braces: #### Example: Using explicit braces rather than indentation for layout #### ~~~~~~~~~~~~~~~~ Name: Test1 Version: 0.0.1 Cabal-Version: >= 1.2 License: BSD3 Author: Jane Doe Synopsis: Test package to test configurations Category: Example Flag Debug { Description: Enable debug support Default: False } Library { Build-Depends: base Exposed-Modules: Testing.Test1 Extensions: CPP if flag(debug) { GHC-Options: -DDEBUG if !os(windows) { CC-Options: "-DDEBUG" } else { CC-Options: "-DNDEBUG" } } } ~~~~~~~~~~~~~~~~ #### Configuration Flags #### A flag section takes the flag name as an argument and may contain the following fields. `description:` _freeform_ : The description of this flag. `default:` _boolean_ (default: `True`) : The default value of this flag. Note that this value may be [overridden in several ways](installing-packages.html#controlling-flag-assignments"). The rationale for having flags default to True is that users usually want new features as soon as they are available. Flags representing features that are not (yet) recommended for most users (such as experimental features or debugging support) should therefore explicitly override the default to False. `manual:` _boolean_ (default: `False`) : By default, Cabal will first try to satisfy dependencies with the default flag value and then, if that is not possible, with the negated value. However, if the flag is manual, then the default value (which can be overridden by commandline flags) will be used. #### Conditional Blocks #### Conditional blocks may appear anywhere inside a library or executable section. They have to follow rather strict formatting rules. Conditional blocks must always be of the shape ~~~~~~~~~~~~~~~~ `if `_condition_ _property-descriptions-or-conditionals*_ ~~~~~~~~~~~~~~~~ or ~~~~~~~~~~~~~~~~ `if `_condition_ _property-descriptions-or-conditionals*_ `else` _property-descriptions-or-conditionals*_ ~~~~~~~~~~~~~~~~ Note that the `if` and the condition have to be all on the same line. #### Conditions #### Conditions can be formed using boolean tests and the boolean operators `||` (disjunction / logical "or"), `&&` (conjunction / logical "and"), or `!` (negation / logical "not"). The unary `!` takes highest precedence, `||` takes lowest. Precedence levels may be overridden through the use of parentheses. For example, `os(darwin) && !arch(i386) || os(freebsd)` is equivalent to `(os(darwin) && !(arch(i386))) || os(freebsd)`. The following tests are currently supported. `os(`_name_`)` : Tests if the current operating system is _name_. The argument is tested against `System.Info.os` on the target system. There is unfortunately some disagreement between Haskell implementations about the standard values of `System.Info.os`. Cabal canonicalises it so that in particular `os(windows)` works on all implementations. If the canonicalised os names match, this test evaluates to true, otherwise false. The match is case-insensitive. `arch(`_name_`)` : Tests if the current architecture is _name_. The argument is matched against `System.Info.arch` on the target system. If the arch names match, this test evaluates to true, otherwise false. The match is case-insensitive. `impl(`_compiler_`)` : Tests for the configured Haskell implementation. An optional version constraint may be specified (for example `impl(ghc >= 6.6.1)`). If the configured implementation is of the right type and matches the version constraint, then this evaluates to true, otherwise false. The match is case-insensitive. `flag(`_name_`)` : Evaluates to the current assignment of the flag of the given name. Flag names are case insensitive. Testing for flags that have not been introduced with a flag section is an error. `true` : Constant value true. `false` : Constant value false. #### Resolution of Conditions and Flags #### If a package descriptions specifies configuration flags the package user can [control these in several ways](installing-packages.html#controlling-flag-assignments). If the user does not fix the value of a flag, Cabal will try to find a flag assignment in the following way. * For each flag specified, it will assign its default value, evaluate all conditions with this flag assignment, and check if all dependencies can be satisfied. If this check succeeded, the package will be configured with those flag assignments. * If dependencies were missing, the last flag (as by the order in which the flags were introduced in the package description) is tried with its alternative value and so on. This continues until either an assignment is found where all dependencies can be satisfied, or all possible flag assignments have been tried. To put it another way, Cabal does a complete backtracking search to find a satisfiable package configuration. It is only the dependencies specified in the `build-depends` field in conditional blocks that determine if a particular flag assignment is satisfiable (`build-tools` are not considered). The order of the declaration and the default value of the flags determines the search order. Flags overridden on the command line fix the assignment of that flag, so no backtracking will be tried for that flag. If no suitable flag assignment could be found, the configuration phase will fail and a list of missing dependencies will be printed. Note that this resolution process is exponential in the worst case (i.e., in the case where dependencies cannot be satisfied). There are some optimizations applied internally, but the overall complexity remains unchanged. ### Meaning of field values when using conditionals ### During the configuration phase, a flag assignment is chosen, all conditionals are evaluated, and the package description is combined into a flat package descriptions. If the same field both inside a conditional and outside then they are combined using the following rules. * Boolean fields are combined using conjunction (logical "and"). * List fields are combined by appending the inner items to the outer items, for example ~~~~~~~~~~~~~~~~ Extensions: CPP if impl(ghc) Extensions: MultiParamTypeClasses ~~~~~~~~~~~~~~~~ when compiled using GHC will be combined to ~~~~~~~~~~~~~~~~ Extensions: CPP, MultiParamTypeClasses ~~~~~~~~~~~~~~~~ Similarly, if two conditional sections appear at the same nesting level, properties specified in the latter will come after properties specified in the former. * All other fields must not be specified in ambiguous ways. For example ~~~~~~~~~~~~~~~~ Main-is: Main.hs if flag(useothermain) Main-is: OtherMain.hs ~~~~~~~~~~~~~~~~ will lead to an error. Instead use ~~~~~~~~~~~~~~~~ if flag(useothermain) Main-is: OtherMain.hs else Main-is: Main.hs ~~~~~~~~~~~~~~~~ ### Source Repositories ### It is often useful to be able to specify a source revision control repository for a package. Cabal lets you specifying this information in a relatively structured form which enables other tools to interpret and make effective use of the information. For example the information should be sufficient for an automatic tool to checkout the sources. Cabal supports specifying different information for various common source control systems. Obviously not all automated tools will support all source control systems. Cabal supports specifying repositories for different use cases. By declaring which case we mean automated tools can be more useful. There are currently two kinds defined: * The `head` kind refers to the latest development branch of the package. This may be used for example to track activity of a project or as an indication to outside developers what sources to get for making new contributions. * The `this` kind refers to the branch and tag of a repository that contains the sources for this version or release of a package. For most source control systems this involves specifying a tag, id or hash of some form and perhaps a branch. The purpose is to be able to reconstruct the sources corresponding to a particular package version. This might be used to indicate what sources to get if someone needs to fix a bug in an older branch that is no longer an active head branch. You can specify one kind or the other or both. As an example here are the repositories for the Cabal library. Note that the `this` kind of repository specifies a tag. ~~~~~~~~~~~~~~~~ source-repository head type: darcs location: http://darcs.haskell.org/cabal/ source-repository this type: darcs location: http://darcs.haskell.org/cabal-branches/cabal-1.6/ tag: 1.6.1 ~~~~~~~~~~~~~~~~ The exact fields are as follows: `type:` _token_ : The name of the source control system used for this repository. The currently recognised types are: * `darcs` * `git` * `svn` * `cvs` * `mercurial` (or alias `hg`) * `bazaar` (or alias `bzr`) * `arch` * `monotone` This field is required. `location:` _URL_ : The location of the repository. The exact form of this field depends on the repository type. For example: * for darcs: `http://code.haskell.org/foo/` * for git: `git://github.com/foo/bar.git` * for CVS: `anoncvs@cvs.foo.org:/cvs` This field is required. `module:` _token_ : CVS requires a named module, as each CVS server can host multiple named repositories. This field is required for the CVS repository type and should not be used otherwise. `branch:` _token_ : Many source control systems support the notion of a branch, as a distinct concept from having repositories in separate locations. For example CVS, SVN and git use branches while for darcs uses different locations for different branches. If you need to specify a branch to identify a your repository then specify it in this field. This field is optional. `tag:` _token_ : A tag identifies a particular state of a source repository. The tag can be used with a `this` repository kind to identify the state of a repository corresponding to a particular package version or release. The exact form of the tag depends on the repository type. This field is required for the `this` repository kind. `subdir:` _directory_ : Some projects put the sources for multiple packages under a single source repository. This field lets you specify the relative path from the root of the repository to the top directory for the package, i.e. the directory containing the package's `.cabal` file. This field is optional. It default to empty which corresponds to the root directory of the repository. ### Downloading a package's source ### The `cabal get` command allows to access a package's source code - either by unpacking a tarball downloaded from Hackage (the default) or by checking out a working copy from the package's source repository. ~~~~~~~~~~~~~~~~ $ cabal get [FLAGS] PACKAGES ~~~~~~~~~~~~~~~~ The `get` command supports the following options: `-d --destdir` _PATH_ : Where to place the package source, defaults to (a subdirectory of) the current directory. `-s --source-repository` _[head|this|...]_ : Fork the package's source repository using the appropriate version control system. The optional argument allows to choose a specific repository kind. ## Accessing data files from package code ## The placement on the target system of files listed in the `data-files` field varies between systems, and in some cases one can even move packages around after installation (see [prefix independence](installing-packages.html#prefix-independence)). To enable packages to find these files in a portable way, Cabal generates a module called `Paths_`_pkgname_ (with any hyphens in _pkgname_ replaced by underscores) during building, so that it may be imported by modules of the package. This module defines a function ~~~~~~~~~~~~~~~ getDataFileName :: FilePath -> IO FilePath ~~~~~~~~~~~~~~~ If the argument is a filename listed in the `data-files` field, the result is the name of the corresponding file on the system on which the program is running. Note: If you decide to import the `Paths_`_pkgname_ module then it *must* be listed in the `other-modules` field just like any other module in your package. The `Paths_`_pkgname_ module is not platform independent so it does not get included in the source tarballs generated by `sdist`. ### Accessing the package version ### The aforementioned auto generated `Paths_`_pkgname_ module also exports the constant `version ::` [Version][data-version] which is defined as the version of your package as specified in the `version` field. ## System-dependent parameters ## For some packages, especially those interfacing with C libraries, implementation details and the build procedure depend on the build environment. The `build-type` `Configure` can be used to handle many such situations. In this case, `Setup.hs` should be: ~~~~~~~~~~~~~~~~ import Distribution.Simple main = defaultMainWithHooks autoconfUserHooks ~~~~~~~~~~~~~~~~ Most packages, however, would probably do better using the `Simple` build type and [configurations](#configurations). The `build-type` `Configure` differs from `Simple` in two ways: * The package root directory must contain a shell script called `configure`. The configure step will run the script. This `configure` script may be produced by [autoconf][] or may be hand-written. The `configure` script typically discovers information about the system and records it for later steps, e.g. by generating system-dependent header files for inclusion in C source files and preprocessed Haskell source files. (Clearly this won't work for Windows without MSYS or Cygwin: other ideas are needed.) * If the package root directory contains a file called _package_`.buildinfo` after the configuration step, subsequent steps will read it to obtain additional settings for [build information](#build-information) fields,to be merged with the ones given in the `.cabal` file. In particular, this file may be generated by the `configure` script mentioned above, allowing these settings to vary depending on the build environment. The build information file should have the following structure: > _buildinfo_ > > `executable:` _name_ > _buildinfo_ > > `executable:` _name_ > _buildinfo_ > ... where each _buildinfo_ consists of settings of fields listed in the section on [build information](#build-information). The first one (if present) relates to the library, while each of the others relate to the named executable. (The names must match the package description, but you don't have to have entries for all of them.) Neither of these files is required. If they are absent, this setup script is equivalent to `defaultMain`. #### Example: Using autoconf #### This example is for people familiar with the [autoconf][] tools. In the X11 package, the file `configure.ac` contains: ~~~~~~~~~~~~~~~~ AC_INIT([Haskell X11 package], [1.1], [libraries@haskell.org], [X11]) # Safety check: Ensure that we are in the correct source directory. AC_CONFIG_SRCDIR([X11.cabal]) # Header file to place defines in AC_CONFIG_HEADERS([include/HsX11Config.h]) # Check for X11 include paths and libraries AC_PATH_XTRA AC_TRY_CPP([#include ],,[no_x=yes]) # Build the package if we found X11 stuff if test "$no_x" = yes then BUILD_PACKAGE_BOOL=False else BUILD_PACKAGE_BOOL=True fi AC_SUBST([BUILD_PACKAGE_BOOL]) AC_CONFIG_FILES([X11.buildinfo]) AC_OUTPUT ~~~~~~~~~~~~~~~~ Then the setup script will run the `configure` script, which checks for the presence of the X11 libraries and substitutes for variables in the file `X11.buildinfo.in`: ~~~~~~~~~~~~~~~~ buildable: @BUILD_PACKAGE_BOOL@ cc-options: @X_CFLAGS@ ld-options: @X_LIBS@ ~~~~~~~~~~~~~~~~ This generates a file `X11.buildinfo` supplying the parameters needed by later stages: ~~~~~~~~~~~~~~~~ buildable: True cc-options: -I/usr/X11R6/include ld-options: -L/usr/X11R6/lib ~~~~~~~~~~~~~~~~ The `configure` script also generates a header file `include/HsX11Config.h` containing C preprocessor defines recording the results of various tests. This file may be included by C source files and preprocessed Haskell source files in the package. Note: Packages using these features will also need to list additional files such as `configure`, templates for `.buildinfo` files, files named only in `.buildinfo` files, header files and so on in the `extra-source-files` field to ensure that they are included in source distributions. They should also list files and directories generated by `configure` in the `extra-tmp-files` field to ensure that they are removed by `setup clean`. Quite often the files generated by `configure` need to be listed somewhere in the package description (for example, in the `install-includes` field). However, we usually don't want generated files to be included in the source tarball. The solution is again provided by the `.buildinfo` file. In the above example, the following line should be added to `X11.buildinfo`: ~~~~~~~~~~~~~~~~ install-includes: HsX11Config.h ~~~~~~~~~~~~~~~~ In this way, the generated `HsX11Config.h` file won't be included in the source tarball in addition to `HsX11Config.h.in`, but it will be copied to the right location during the install process. Packages that use custom `Setup.hs` scripts can update the necessary fields programmatically instead of using the `.buildinfo` file. ## Conditional compilation ## Sometimes you want to write code that works with more than one version of a dependency. You can specify a range of versions for the dependency in the `build-depends`, but how do you then write the code that can use different versions of the API? Haskell lets you preprocess your code using the C preprocessor (either the real C preprocessor, or `cpphs`). To enable this, add `extensions: CPP` to your package description. When using CPP, Cabal provides some pre-defined macros to let you test the version of dependent packages; for example, suppose your package works with either version 3 or version 4 of the `base` package, you could select the available version in your Haskell modules like this: ~~~~~~~~~~~~~~~~ #if MIN_VERSION_base(4,0,0) ... code that works with base-4 ... #else ... code that works with base-3 ... #endif ~~~~~~~~~~~~~~~~ In general, Cabal supplies a macro `MIN_VERSION_`_`package`_`_(A,B,C)` for each package depended on via `build-depends`. This macro is true if the actual version of the package in use is greater than or equal to `A.B.C` (using the conventional ordering on version numbers, which is lexicographic on the sequence, but numeric on each component, so for example 1.2.0 is greater than 1.0.3). Since version 1.20, there is also the `MIN_TOOL_VERSION_`_`tool`_ family of macros for conditioning on the version of build tools used to build the program (e.g. `hsc2hs`). Cabal places the definitions of these macros into an automatically-generated header file, which is included when preprocessing Haskell source code by passing options to the C preprocessor. Cabal also allows to detect when the source code is being used for generating documentation. The `__HADDOCK_VERSION__` macro is defined only when compiling via [haddock][] instead of a normal Haskell compiler. The value of the `__HADDOCK_VERSION__` macro is defined as `A*1000 + B*10 + C`, where `A.B.C` is the Haddock version. This can be useful for working around bugs in Haddock or generating prettier documentation in some special cases. ## More complex packages ## For packages that don't fit the simple schemes described above, you have a few options: * By using the `build-type` `Custom`, you can supply your own `Setup.hs` file, and customize the simple build infrastructure using _hooks_. These allow you to perform additional actions before and after each command is run, and also to specify additional preprocessors. A typical `Setup.hs` may look like this: ~~~~~~~~~~~~~~~~ import Distribution.Simple main = defaultMainWithHooks simpleUserHooks { postHaddock = posthaddock } posthaddock args flags desc info = .... ~~~~~~~~~~~~~~~~ See `UserHooks` in [Distribution.Simple][dist-simple] for the details, but note that this interface is experimental, and likely to change in future releases. * You could delegate all the work to `make`, though this is unlikely to be very portable. Cabal supports this with the `build-type` `Make` and a trivial setup library [Distribution.Make][dist-make], which simply parses the command line arguments and invokes `make`. Here `Setup.hs` should look like this: ~~~~~~~~~~~~~~~~ import Distribution.Make main = defaultMain ~~~~~~~~~~~~~~~~ The root directory of the package should contain a `configure` script, and, after that has run, a `Makefile` with a default target that builds the package, plus targets `install`, `register`, `unregister`, `clean`, `dist` and `docs`. Some options to commands are passed through as follows: * The `--with-hc-pkg`, `--prefix`, `--bindir`, `--libdir`, `--datadir`, `--libexecdir` and `--sysconfdir` options to the `configure` command are passed on to the `configure` script. In addition the value of the `--with-compiler` option is passed in a `--with-hc` option and all options specified with `--configure-option=` are passed on. * The `--destdir` option to the `copy` command becomes a setting of a `destdir` variable on the invocation of `make copy`. The supplied `Makefile` should provide a `copy` target, which will probably look like this: ~~~~~~~~~~~~~~~~ copy : $(MAKE) install prefix=$(destdir)/$(prefix) \ bindir=$(destdir)/$(bindir) \ libdir=$(destdir)/$(libdir) \ datadir=$(destdir)/$(datadir) \ libexecdir=$(destdir)/$(libexecdir) \ sysconfdir=$(destdir)/$(sysconfdir) \ ~~~~~~~~~~~~~~~~ * Finally, with the `build-type` `Custom`, you can also write your own setup script from scratch. It must conform to the interface described in the section on [building and installing packages](installing-packages.html), and you may use the Cabal library for all or part of the work. One option is to copy the source of `Distribution.Simple`, and alter it for your needs. Good luck. [dist-simple]: ../release/cabal-latest/doc/API/Cabal/Distribution-Simple.html [dist-make]: ../release/cabal-latest/doc/API/Cabal/Distribution-Make.html [dist-license]: ../release/cabal-latest/doc/API/Cabal/Distribution-License.html#t:License [extension]: ../release/cabal-latest/doc/API/Cabal/Language-Haskell-Extension.html#t:Extension [BuildType]: ../release/cabal-latest/doc/API/Cabal/Distribution-PackageDescription.html#t:BuildType [data-version]: http://hackage.haskell.org/packages/archive/base/latest/doc/html/Data-Version.html [alex]: http://www.haskell.org/alex/ [autoconf]: http://www.gnu.org/software/autoconf/ [c2hs]: http://www.cse.unsw.edu.au/~chak/haskell/c2hs/ [cpphs]: http://projects.haskell.org/cpphs/ [greencard]: http://hackage.haskell.org/package/greencard [haddock]: http://www.haskell.org/haddock/ [HsColour]: http://www.cs.york.ac.uk/fp/darcs/hscolour/ [happy]: http://www.haskell.org/happy/ [Hackage]: http://hackage.haskell.org/ [pkg-config]: http://www.freedesktop.org/wiki/Software/pkg-config/ [REPL]: http://en.wikipedia.org/wiki/Read%E2%80%93eval%E2%80%93print_loop Cabal-1.22.5.0/doc/index.markdown0000644000000000000000000001743712627136221014565 0ustar0000000000000000% Cabal User Guide Cabal is the standard package system for [Haskell] software. It helps people to configure, build and install Haskell software and to distribute it easily to other users and developers. There is a command line tool called `cabal` for working with Cabal packages. It helps with installing existing packages and also helps people developing their own packages. It can be used to work with local packages or to install packages from online package archives, including automatically installing dependencies. By default it is configured to use [Hackage] which is Haskell's central package archive that contains thousands of libraries and applications in the Cabal package format. # Contents # * [Introduction](#introduction) - [What's in a package](#whats-in-a-package) - [A tool for working with packages](#a-tool-for-working-with-packages) * [Building, installing and managing packages](installing-packages.html) * [Creating packages](developing-packages.html) * [Reporting bugs and deficiencies](misc.html#reporting-bugs-and-deficiencies) * [Stability of Cabal interfaces](misc.html#stability-of-cabal-interfaces) # Introduction # Cabal is a package system for Haskell software. The point of a package system is to enable software developers and users to easily distribute, use and reuse software. A package system makes it easier for developers to get their software into the hands of users. Equally importantly, it makes it easier for software developers to be able to reuse software components written by other developers. Packaging systems deal with packages and with Cabal we call them _Cabal packages_. The Cabal package is the unit of distribution. Every Cabal package has a name and a version number which are used to identify the package, e.g. `filepath-1.0`. Cabal packages can depend on other Cabal packages. There are tools to enable automated package management. This means it is possible for developers and users to install a package plus all of the other Cabal packages that it depends on. It also means that it is practical to make very modular systems using lots of packages that reuse code written by many developers. Cabal packages are source based and are typically (but not necessarily) portable to many platforms and Haskell implementations. The Cabal package format is designed to make it possible to translate into other formats, including binary packages for various systems. When distributed, Cabal packages use the standard compressed tarball format, with the file extension `.tar.gz`, e.g. `filepath-1.0.tar.gz`. Note that packages are not part of the Haskell language, rather they are a feature provided by the combination of Cabal and GHC (and several other Haskell implementations). ## A tool for working with packages ## There is a command line tool, called "`cabal`", that users and developers can use to build and install Cabal packages. It can be used for both local packages and for packages available remotely over the network. It can automatically install Cabal packages plus any other Cabal packages they depend on. Developers can use the tool with packages in local directories, e.g. ~~~~~~~~~~~~~~~~ cd foo/ cabal install ~~~~~~~~~~~~~~~~ While working on a package in a local directory, developers can run the individual steps to configure and build, and also generate documentation and run test suites and benchmarks. It is also possible to install several local packages at once, e.g. ~~~~~~~~~~~~~~~~ cabal install foo/ bar/ ~~~~~~~~~~~~~~~~ Developers and users can use the tool to install packages from remote Cabal package archives. By default, the `cabal` tool is configured to use the central Haskell package archive called [Hackage] but it is possible to use it with any other suitable archive. ~~~~~~~~~~~~~~~~ cabal install xmonad ~~~~~~~~~~~~~~~~ This will install the `xmonad` package plus all of its dependencies. In addition to packages that have been published in an archive, developers can install packages from local or remote tarball files, for example ~~~~~~~~~~~~~~~~ cabal install foo-1.0.tar.gz cabal install http://example.com/foo-1.0.tar.gz ~~~~~~~~~~~~~~~~ Cabal provides a number of ways for a user to customise how and where a package is installed. They can decide where a package will be installed, which Haskell implementation to use and whether to build optimised code or build with the ability to profile code. It is not expected that users will have to modify any of the information in the `.cabal` file. For full details, see the section on [building and installing packages](installing-packages.html). Note that `cabal` is not the only tool for working with Cabal packages. Due to the standardised format and a library for reading `.cabal` files, there are several other special-purpose tools. ## What's in a package ## A Cabal package consists of: * Haskell software, including libraries, executables and tests * metadata about the package in a standard human and machine readable format (the "`.cabal`" file) * a standard interface to build the package (the "`Setup.hs`" file) The `.cabal` file contains information about the package, supplied by the package author. In particular it lists the other Cabal packages that the package depends on. For full details on what goes in the `.cabal` and `Setup.hs` files, and for all the other features provided by the build system, see the section on [developing packages](developing-packages.html). ## Cabal featureset ## Cabal and its associated tools and websites covers: * a software build system * software configuration * packaging for distribution * automated package management * natively using the `cabal` command line tool; or * by translation into native package formats such as RPM or deb * web and local Cabal package archives * central Hackage website with 1000's of Cabal packages Some parts of the system can be used without others. In particular the built-in build system for simple packages is optional: it is possible to use custom build systems. ## Similar systems ## The Cabal system is roughly comparable with the system of Python Eggs, Ruby Gems or Perl distributions. Each system has a notion of distributable packages, and has tools to manage the process of distributing and installing packages. Hackage is an online archive of Cabal packages. It is roughly comparable to CPAN but with rather fewer packages (around 5,000 vs 28,000). Cabal is often compared with autoconf and automake and there is some overlap in functionality. The most obvious similarity is that the command line interface for actually configuring and building packages follows the same steps and has many of the same configuration parameters. ~~~~~~~~~~ ./configure --prefix=... make make install ~~~~~~~~~~ compared to ~~~~~~~~~~ cabal configure --prefix=... cabal build cabal install ~~~~~~~~~~ Cabal's build system for simple packages is considerably less flexible than make/automake, but has builtin knowledge of how to build Haskell code and requires very little manual configuration. Cabal's simple build system is also portable to Windows, without needing a Unix-like environment such as cygwin/mingwin. Compared to autoconf, Cabal takes a somewhat different approach to package configuration. Cabal's approach is designed for automated package management. Instead of having a configure script that tests for whether dependencies are available, Cabal packages specify their dependencies. There is some scope for optional and conditional dependencies. By having package authors specify dependencies it makes it possible for tools to install a package and all of its dependencies automatically. It also makes it possible to translate (in a mostly-automatically way) into another package format like RPM or deb which also have automatic dependency resolution. [Haskell]: http://www.haskell.org/ [Hackage]: http://hackage.haskell.org/ Cabal-1.22.5.0/doc/installing-packages.markdown0000644000000000000000000012560312627136221017371 0ustar0000000000000000% Cabal User Guide # Building and installing packages # After you've unpacked a Cabal package, you can build it by moving into the root directory of the package and running the `cabal` tool there: > `cabal [command] [option...]` The _command_ argument selects a particular step in the build/install process. You can also get a summary of the command syntax with > `cabal help` Alternatively, you can also use the `Setup.hs` or `Setup.lhs` script: > `runhaskell Setup.hs [command] [option...]` For the summary of the command syntax, run: > `cabal help` or > `runhaskell Setup.hs --help` ## Building and installing a system package ## ~~~~~~~~~~~~~~~~ runhaskell Setup.hs configure --ghc runhaskell Setup.hs build runhaskell Setup.hs install ~~~~~~~~~~~~~~~~ The first line readies the system to build the tool using GHC; for example, it checks that GHC exists on the system. The second line performs the actual building, while the last both copies the build results to some permanent place and registers the package with GHC. ## Building and installing a user package ## ~~~~~~~~~~~~~~~~ runhaskell Setup.hs configure --user runhaskell Setup.hs build runhaskell Setup.hs install ~~~~~~~~~~~~~~~~ The package is installed under the user's home directory and is registered in the user's package database (`--user`). ## Installing packages from Hackage ## The `cabal` tool also can download, configure, build and install a [Hackage] package and all of its dependencies in a single step. To do this, run: ~~~~~~~~~~~~~~~~ cabal install [PACKAGE...] ~~~~~~~~~~~~~~~~ To browse the list of available packages, visit the [Hackage] web site. ## Developing with sandboxes ## By default, any dependencies of the package are installed into the global or user package databases (e.g. using `cabal install --only-dependencies`). If you're building several different packages that have incompatible dependencies, this can cause the build to fail. One way to avoid this problem is to build each package in an isolated environment ("sandbox"), with a sandbox-local package database. Because sandboxes are per-project, inconsistent dependencies can be simply disallowed. For more on sandboxes, see also [this article](http://coldwa.st/e/blog/2013-08-20-Cabal-sandbox.html). ### Sandboxes: basic usage ### To initialise a fresh sandbox in the current directory, run `cabal sandbox init`. All subsequent commands (such as `build` and `install`) from this point will use the sandbox. ~~~~~~~~~~~~~~~ $ cd /path/to/my/haskell/library $ cabal sandbox init # Initialise the sandbox $ cabal install --only-dependencies # Install dependencies into the sandbox $ cabal build # Build your package inside the sandbox ~~~~~~~~~~~~~~~ It can be useful to make a source package available for installation in the sandbox - for example, if your package depends on a patched or an unreleased version of a library. This can be done with the `cabal sandbox add-source` command - think of it as "local [Hackage]". If an add-source dependency is later modified, it is reinstalled automatically. ~~~~~~~~~~~~~~~ $ cabal sandbox add-source /my/patched/library # Add a new add-source dependency $ cabal install --dependencies-only # Install it into the sandbox $ cabal build # Build the local package $ $EDITOR /my/patched/library/Source.hs # Modify the add-source dependency $ cabal build # Modified dependency is automatically reinstalled ~~~~~~~~~~~~~~~ Normally, the sandbox settings (such as optimisation level) are inherited from the main Cabal config file (`$HOME/cabal/config`). Sometimes, though, you need to change some settings specifically for a single sandbox. You can do this by creating a `cabal.config` file in the same directory with your `cabal.sandbox.config` (which was created by `sandbox init`). This file has the same syntax as the main Cabal config file. ~~~~~~~~~~~~~~~ $ cat cabal.config documentation: True constraints: foo == 1.0, bar >= 2.0, baz $ cabal build # Uses settings from the cabal.config file ~~~~~~~~~~~~~~~ When you have decided that you no longer want to build your package inside a sandbox, just delete it: ~~~~~~~~~~~~~~~ $ cabal sandbox delete # Built-in command $ rm -rf .cabal-sandbox cabal.sandbox.config # Alternative manual method ~~~~~~~~~~~~~~~ ### Sandboxes: advanced usage ### The default behaviour of the `add-source` command is to track modifications done to the added dependency and reinstall the sandbox copy of the package when needed. Sometimes this is not desirable: in these cases you can use `add-source --snapshot`, which disables the change tracking. In addition to `add-source`, there are also `list-sources` and `delete-source` commands. Sometimes one wants to share a single sandbox between multiple packages. This can be easily done with the `--sandbox` option: ~~~~~~~~~~~~~~~ $ mkdir -p /path/to/shared-sandbox $ cd /path/to/shared-sandbox $ cabal sandbox init --sandbox . $ cd /path/to/package-a $ cabal sandbox init --sandbox /path/to/shared-sandbox $ cd /path/to/package-b $ cabal sandbox init --sandbox /path/to/shared-sandbox ~~~~~~~~~~~~~~~ Note that `cabal sandbox init --sandbox .` puts all sandbox files into the current directory. By default, `cabal sandbox init` initialises a new sandbox in a newly-created subdirectory of the current working directory (`./.cabal-sandbox`). Using multiple different compiler versions simultaneously is also supported, via the `-w` option: ~~~~~~~~~~~~~~~ $ cabal sandbox init $ cabal install --only-dependencies -w /path/to/ghc-1 # Install dependencies for both compilers $ cabal install --only-dependencies -w /path/to/ghc-2 $ cabal configure -w /path/to/ghc-1 # Build with the first compiler $ cabal build $ cabal configure -w /path/to/ghc-2 # Build with the second compiler $ cabal build ~~~~~~~~~~~~~~~ It can be occasionally useful to run the compiler-specific package manager tool (e.g. `ghc-pkg`) tool on the sandbox package DB directly (for example, you may need to unregister some packages). The `cabal sandbox hc-pkg` command is a convenient wrapper that runs the compiler-specific package manager tool with the arguments: ~~~~~~~~~~~~~~~ $ cabal -v sandbox hc-pkg list Using a sandbox located at /path/to/.cabal-sandbox 'ghc-pkg' '--global' '--no-user-package-conf' '--package-conf=/path/to/.cabal-sandbox/i386-linux-ghc-7.4.2-packages.conf.d' 'list' [...] ~~~~~~~~~~~~~~~ The `--require-sandbox` option makes all sandbox-aware commands (`install`/`build`/etc.) exit with error if there is no sandbox present. This makes it harder to accidentally modify the user package database. The option can be also turned on via the per-user configuration file (`~/.cabal/config`) or the per-project one (`$PROJECT_DIR/cabal.config`). The error can be squelched with `--no-require-sandbox`. The option `--sandbox-config-file` allows to specify the location of the `cabal.sandbox.config` file (by default, `cabal` searches for it in the current directory). This provides the same functionality as shared sandboxes, but sometimes can be more convenient. Example: ~~~~~~~~~~~~~~~ $ mkdir my/sandbox $ cd my/sandbox $ cabal sandbox init $ cd /path/to/my/project $ cabal --sandbox-config-file=/path/to/my/sandbox/cabal.sandbox.config install # Uses the sandbox located at /path/to/my/sandbox/.cabal-sandbox $ cd ~ $ cabal --sandbox-config-file=/path/to/my/sandbox/cabal.sandbox.config install # Still uses the same sandbox ~~~~~~~~~~~~~~~ The sandbox config file can be also specified via the `CABAL_SANDBOX_CONFIG` environment variable. Finally, the flag `--ignore-sandbox` lets you temporarily ignore an existing sandbox: ~~~~~~~~~~~~~~~ $ mkdir my/sandbox $ cd my/sandbox $ cabal sandbox init $ cabal --ignore-sandbox install text # Installs 'text' in the user package database ('~/.cabal'). ~~~~~~~~~~~~~~~ ## Creating a binary package ## When creating binary packages (e.g. for Red Hat or Debian) one needs to create a tarball that can be sent to another system for unpacking in the root directory: ~~~~~~~~~~~~~~~~ runhaskell Setup.hs configure --prefix=/usr runhaskell Setup.hs build runhaskell Setup.hs copy --destdir=/tmp/mypkg tar -czf mypkg.tar.gz /tmp/mypkg/ ~~~~~~~~~~~~~~~~ If the package contains a library, you need two additional steps: ~~~~~~~~~~~~~~~~ runhaskell Setup.hs register --gen-script runhaskell Setup.hs unregister --gen-script ~~~~~~~~~~~~~~~~ This creates shell scripts `register.sh` and `unregister.sh`, which must also be sent to the target system. After unpacking there, the package must be registered by running the `register.sh` script. The `unregister.sh` script would be used in the uninstall procedure of the package. Similar steps may be used for creating binary packages for Windows. The following options are understood by all commands: `--help`, `-h` or `-?` : List the available options for the command. `--verbose=`_n_ or `-v`_n_ : Set the verbosity level (0-3). The normal level is 1; a missing _n_ defaults to 2. The various commands and the additional options they support are described below. In the simple build infrastructure, any other options will be reported as errors. ## setup configure ## Prepare to build the package. Typically, this step checks that the target platform is capable of building the package, and discovers platform-specific features that are needed during the build. The user may also adjust the behaviour of later stages using the options listed in the following subsections. In the simple build infrastructure, the values supplied via these options are recorded in a private file read by later stages. If a user-supplied `configure` script is run (see the section on [system-dependent parameters](developing-packages.html#system-dependent-parameters) or on [complex packages](developing-packages.html#more-complex-packages)), it is passed the `--with-hc-pkg`, `--prefix`, `--bindir`, `--libdir`, `--datadir`, `--libexecdir` and `--sysconfdir` options. In addition the value of the `--with-compiler` option is passed in a `--with-hc` option and all options specified with `--configure-option=` are passed on. ### Programs used for building ### The following options govern the programs used to process the source files of a package: `--ghc` or `-g`, `--jhc`, `--lhc`, `--uhc` : Specify which Haskell implementation to use to build the package. At most one of these flags may be given. If none is given, the implementation under which the setup script was compiled or interpreted is used. `--with-compiler=`_path_ or `-w`_path_ : Specify the path to a particular compiler. If given, this must match the implementation selected above. The default is to search for the usual name of the selected implementation. This flag also sets the default value of the `--with-hc-pkg` option to the package tool for this compiler. Check the output of `setup configure -v` to ensure that it finds the right package tool (or use `--with-hc-pkg` explicitly). `--with-hc-pkg=`_path_ : Specify the path to the package tool, e.g. `ghc-pkg`. The package tool must be compatible with the compiler specified by `--with-compiler`. If this option is omitted, the default value is determined from the compiler selected. `--with-`_`prog`_`=`_path_ : Specify the path to the program _prog_. Any program known to Cabal can be used in place of _prog_. It can either be a fully path or the name of a program that can be found on the program search path. For example: `--with-ghc=ghc-6.6.1` or `--with-cpphs=/usr/local/bin/cpphs`. The full list of accepted programs is not enumerated in this user guide. Rather, run `cabal install --help` to view the list. `--`_`prog`_`-options=`_options_ : Specify additional options to the program _prog_. Any program known to Cabal can be used in place of _prog_. For example: `--alex-options="--template=mytemplatedir/"`. The _options_ is split into program options based on spaces. Any options containing embedded spaced need to be quoted, for example `--foo-options='--bar="C:\Program File\Bar"'`. As an alternative that takes only one option at a time but avoids the need to quote, use `--`_`prog`_`-option` instead. `--`_`prog`_`-option=`_option_ : Specify a single additional option to the program _prog_. For passing an option that contain embedded spaces, such as a file name with embedded spaces, using this rather than `--`_`prog`_`-options` means you do not need an additional level of quoting. Of course if you are using a command shell you may still need to quote, for example `--foo-options="--bar=C:\Program File\Bar"`. All of the options passed with either `--`_`prog`_`-options` or `--`_`prog`_`-option` are passed in the order they were specified on the configure command line. ### Installation paths ### The following options govern the location of installed files from a package: `--prefix=`_dir_ : The root of the installation. For example for a global install you might use `/usr/local` on a Unix system, or `C:\Program Files` on a Windows system. The other installation paths are usually subdirectories of _prefix_, but they don't have to be. In the simple build system, _dir_ may contain the following path variables: `$pkgid`, `$pkg`, `$version`, `$compiler`, `$os`, `$arch`, `$abi`, `$abitag` `--bindir=`_dir_ : Executables that the user might invoke are installed here. In the simple build system, _dir_ may contain the following path variables: `$prefix`, `$pkgid`, `$pkg`, `$version`, `$compiler`, `$os`, `$arch`, `$abi`, `$abitag `--libdir=`_dir_ : Object-code libraries are installed here. In the simple build system, _dir_ may contain the following path variables: `$prefix`, `$bindir`, `$pkgid`, `$pkg`, `$version`, `$compiler`, `$os`, `$arch`, `$abi`, `$abitag` `--libexecdir=`_dir_ : Executables that are not expected to be invoked directly by the user are installed here. In the simple build system, _dir_ may contain the following path variables: `$prefix`, `$bindir`, `$libdir`, `$libsubdir`, `$pkgid`, `$pkg`, `$version`, `$compiler`, `$os`, `$arch`, `$abi`, `$abitag` `--datadir`=_dir_ : Architecture-independent data files are installed here. In the simple build system, _dir_ may contain the following path variables: `$prefix`, `$bindir`, `$libdir`, `$libsubdir`, `$pkgid`, `$pkg`, `$version`, `$compiler`, `$os`, `$arch`, `$abi`, `$abitag` `--sysconfdir=`_dir_ : Installation directory for the configuration files. In the simple build system, _dir_ may contain the following path variables: `$prefix`, `$bindir`, `$libdir`, `$libsubdir`, `$pkgid`, `$pkg`, `$version`, `$compiler`, `$os`, `$arch`, `$abi`, `$abitag` In addition the simple build system supports the following installation path options: `--libsubdir=`_dir_ : A subdirectory of _libdir_ in which libraries are actually installed. For example, in the simple build system on Unix, the default _libdir_ is `/usr/local/lib`, and _libsubdir_ contains the package identifier and compiler, e.g. `mypkg-0.2/ghc-6.4`, so libraries would be installed in `/usr/local/lib/mypkg-0.2/ghc-6.4`. _dir_ may contain the following path variables: `$pkgid`, `$pkg`, `$version`, `$compiler`, `$os`, `$arch`, `$abi`, `$abitag` `--datasubdir=`_dir_ : A subdirectory of _datadir_ in which data files are actually installed. _dir_ may contain the following path variables: `$pkgid`, `$pkg`, `$version`, `$compiler`, `$os`, `$arch`, `$abi`, `$abitag` `--docdir=`_dir_ : Documentation files are installed relative to this directory. _dir_ may contain the following path variables: `$prefix`, `$bindir`, `$libdir`, `$libsubdir`, `$datadir`, `$datasubdir`, `$pkgid`, `$pkg`, `$version`, `$compiler`, `$os`, `$arch`, `$abi`, `$abitag` `--htmldir=`_dir_ : HTML documentation files are installed relative to this directory. _dir_ may contain the following path variables: `$prefix`, `$bindir`, `$libdir`, `$libsubdir`, `$datadir`, `$datasubdir`, `$docdir`, `$pkgid`, `$pkg`, `$version`, `$compiler`, `$os`, `$arch`, `$abi`, `$abitag` `--program-prefix=`_prefix_ : Prepend _prefix_ to installed program names. _prefix_ may contain the following path variables: `$pkgid`, `$pkg`, `$version`, `$compiler`, `$os`, `$arch`, `$abi`, `$abitag` `--program-suffix=`_suffix_ : Append _suffix_ to installed program names. The most obvious use for this is to append the program's version number to make it possible to install several versions of a program at once: `--program-suffix='$version'`. _suffix_ may contain the following path variables: `$pkgid`, `$pkg`, `$version`, `$compiler`, `$os`, `$arch`, `$abi`, `$abitag` #### Path variables in the simple build system #### For the simple build system, there are a number of variables that can be used when specifying installation paths. The defaults are also specified in terms of these variables. A number of the variables are actually for other paths, like `$prefix`. This allows paths to be specified relative to each other rather than as absolute paths, which is important for building relocatable packages (see [prefix independence](#prefix-independence)). `$prefix` : The path variable that stands for the root of the installation. For an installation to be relocatable, all other installation paths must be relative to the `$prefix` variable. `$bindir` : The path variable that expands to the path given by the `--bindir` configure option (or the default). `$libdir` : As above but for `--libdir` `$libsubdir` : As above but for `--libsubdir` `$datadir` : As above but for `--datadir` `$datasubdir` : As above but for `--datasubdir` `$docdir` : As above but for `--docdir` `$pkgid` : The name and version of the package, e.g. `mypkg-0.2` `$pkg` : The name of the package, e.g. `mypkg` `$version` : The version of the package, e.g. `0.2` `$compiler` : The compiler being used to build the package, e.g. `ghc-6.6.1` `$os` : The operating system of the computer being used to build the package, e.g. `linux`, `windows`, `osx`, `freebsd` or `solaris` `$arch` : The architecture of the computer being used to build the package, e.g. `i386`, `x86_64`, `ppc` or `sparc` `$abitag` : An optional tag that a compiler can use for telling incompatible ABI's on the same architecture apart. GHCJS encodes the underlying GHC version in the ABI tag. `$abi` : A shortcut for getting a path that completely identifies the platform in terms of binary compatibility. Expands to the same value as `$arch-$os-compiler-$abitag` if the compiler uses an abi tag, `$arch-$os-$compiler` if it doesn't. #### Paths in the simple build system #### For the simple build system, the following defaults apply: Option Windows Default Unix Default ------- ---------------- ------------- `--prefix` (global) `C:\Program Files\Haskell` `/usr/local` `--prefix` (per-user) `C:\Documents And Settings\user\Application Data\cabal` `$HOME/.cabal` `--bindir` `$prefix\bin` `$prefix/bin` `--libdir` `$prefix` `$prefix/lib` `--libsubdir` (others) `$pkgid\$compiler` `$pkgid/$compiler` `--libexecdir` `$prefix\$pkgid` `$prefix/libexec` `--datadir` (executable) `$prefix` `$prefix/share` `--datadir` (library) `C:\Program Files\Haskell` `$prefix/share` `--datasubdir` `$pkgid` `$pkgid` `--docdir` `$prefix\doc\$pkgid` `$datadir/doc/$pkgid` `--sysconfdir` `$prefix\etc` `$prefix/etc` `--htmldir` `$docdir\html` `$docdir/html` `--program-prefix` (empty) (empty) `--program-suffix` (empty) (empty) #### Prefix-independence #### On Windows it is possible to obtain the pathname of the running program. This means that we can construct an installable executable package that is independent of its absolute install location. The executable can find its auxiliary files by finding its own path and knowing the location of the other files relative to `$bindir`. Prefix-independence is particularly useful: it means the user can choose the install location (i.e. the value of `$prefix`) at install-time, rather than having to bake the path into the binary when it is built. In order to achieve this, we require that for an executable on Windows, all of `$bindir`, `$libdir`, `$datadir` and `$libexecdir` begin with `$prefix`. If this is not the case then the compiled executable will have baked-in all absolute paths. The application need do nothing special to achieve prefix-independence. If it finds any files using `getDataFileName` and the [other functions provided for the purpose](developing-packages.html#accessing-data-files-from-package-code), the files will be accessed relative to the location of the current executable. A library cannot (currently) be prefix-independent, because it will be linked into an executable whose file system location bears no relation to the library package. ### Controlling Flag Assignments ### Flag assignments (see the [resolution of conditions and flags](developing-packages.html#resolution-of-conditions-and-flags)) can be controlled with the following command line options. `-f` _flagname_ or `-f` `-`_flagname_ : Force the specified flag to `true` or `false` (if preceded with a `-`). Later specifications for the same flags will override earlier, i.e., specifying `-fdebug -f-debug` is equivalent to `-f-debug` `--flags=`_flagspecs_ : Same as `-f`, but allows specifying multiple flag assignments at once. The parameter is a space-separated list of flag names (to force a flag to `true`), optionally preceded by a `-` (to force a flag to `false`). For example, `--flags="debug -feature1 feature2"` is equivalent to `-fdebug -f-feature1 -ffeature2`. ### Building Test Suites ### `--enable-tests` : Build the test suites defined in the package description file during the `build` stage. Check for dependencies required by the test suites. If the package is configured with this option, it will be possible to run the test suites with the `test` command after the package is built. `--disable-tests` : (default) Do not build any test suites during the `build` stage. Do not check for dependencies required only by the test suites. It will not be possible to invoke the `test` command without reconfiguring the package. `--enable-coverage` : Build libraries and executables (including test suites) with Haskell Program Coverage enabled. Running the test suites will automatically generate coverage reports with HPC. `--disable-coverage` : (default) Do not enable Haskell Program Coverage. ### Miscellaneous options ## `--user` : Does a per-user installation. This changes the [default installation prefix](#paths-in-the-simple-build-system). It also allow dependencies to be satisfied by the user's package database, in addition to the global database. This also implies a default of `--user` for any subsequent `install` command, as packages registered in the global database should not depend on packages registered in a user's database. `--global` : (default) Does a global installation. In this case package dependencies must be satisfied by the global package database. All packages in the user's package database will be ignored. Typically the final installation step will require administrative privileges. `--package-db=`_db_ : Allows package dependencies to be satisfied from this additional package database _db_ in addition to the global package database. All packages in the user's package database will be ignored. The interpretation of _db_ is implementation-specific. Typically it will be a file or directory. Not all implementations support arbitrary package databases. `--enable-optimization`[=_n_] or `-O`[_n_] : (default) Build with optimization flags (if available). This is appropriate for production use, taking more time to build faster libraries and programs. The optional _n_ value is the optimisation level. Some compilers support multiple optimisation levels. The range is 0 to 2. Level 0 is equivalent to `--disable-optimization`, level 1 is the default if no _n_ parameter is given. Level 2 is higher optimisation if the compiler supports it. Level 2 is likely to lead to longer compile times and bigger generated code. `--disable-optimization` : Build without optimization. This is suited for development: building will be quicker, but the resulting library or programs will be slower. `--enable-library-profiling` or `-p` : Request that an additional version of the library with profiling features enabled be built and installed (only for implementations that support profiling). `--disable-library-profiling` : (default) Do not generate an additional profiling version of the library. `--enable-profiling` : Any executables generated should have profiling enabled (only for implementations that support profiling). For this to work, all libraries used by these executables must also have been built with profiling support. The library will be built with profiling enabled (if supported) unless `--disable-library-profiling` is specified. `--disable-profiling` : (default) Do not enable profiling in generated executables. `--enable-library-vanilla` : (default) Build ordinary libraries (as opposed to profiling libraries). This is independent of the `--enable-library-profiling` option. If you enable both, you get both. `--disable-library-vanilla` : Do not build ordinary libraries. This is useful in conjunction with `--enable-library-profiling` to build only profiling libraries, rather than profiling and ordinary libraries. `--enable-library-for-ghci` : (default) Build libraries suitable for use with GHCi. `--disable-library-for-ghci` : Not all platforms support GHCi and indeed on some platforms, trying to build GHCi libs fails. In such cases this flag can be used as a workaround. `--enable-split-objs` : Use the GHC `-split-objs` feature when building the library. This reduces the final size of the executables that use the library by allowing them to link with only the bits that they use rather than the entire library. The downside is that building the library takes longer and uses considerably more memory. `--disable-split-objs` : (default) Do not use the GHC `-split-objs` feature. This makes building the library quicker but the final executables that use the library will be larger. `--enable-executable-stripping` : (default) When installing binary executable programs, run the `strip` program on the binary. This can considerably reduce the size of the executable binary file. It does this by removing debugging information and symbols. While such extra information is useful for debugging C programs with traditional debuggers it is rarely helpful for debugging binaries produced by Haskell compilers. Not all Haskell implementations generate native binaries. For such implementations this option has no effect. `--disable-executable-stripping` : Do not strip binary executables during installation. You might want to use this option if you need to debug a program using gdb, for example if you want to debug the C parts of a program containing both Haskell and C code. Another reason is if your are building a package for a system which has a policy of managing the stripping itself (such as some Linux distributions). `--enable-shared` : Build shared library. This implies a separate compiler run to generate position independent code as required on most platforms. `--disable-shared` : (default) Do not build shared library. `--enable-executable-dynamic` : Link executables dynamically. The executable's library dependencies should be built as shared objects. This implies `--enable-shared` unless `--disable-shared` is explicitly specified. `--disable-executable-dynamic` : (default) Link executables statically. `--configure-option=`_str_ : An extra option to an external `configure` script, if one is used (see the section on [system-dependent parameters](developing-packages.html#system-dependent-parameters)). There can be several of these options. `--extra-include-dirs`[=_dir_] : An extra directory to search for C header files. You can use this flag multiple times to get a list of directories. You might need to use this flag if you have standard system header files in a non-standard location that is not mentioned in the package's `.cabal` file. Using this option has the same affect as appending the directory _dir_ to the `include-dirs` field in each library and executable in the package's `.cabal` file. The advantage of course is that you do not have to modify the package at all. These extra directories will be used while building the package and for libraries it is also saved in the package registration information and used when compiling modules that use the library. `--extra-lib-dirs`[=_dir_] : An extra directory to search for system libraries files. You can use this flag multiple times to get a list of directories. You might need to use this flag if you have standard system libraries in a non-standard location that is not mentioned in the package's `.cabal` file. Using this option has the same affect as appending the directory _dir_ to the `extra-lib-dirs` field in each library and executable in the package's `.cabal` file. The advantage of course is that you do not have to modify the package at all. These extra directories will be used while building the package and for libraries it is also saved in the package registration information and used when compiling modules that use the library. `--allow-newer`[=_pkgs_] : Selectively relax upper bounds in dependencies without editing the package description. If you want to install a package A that depends on B >= 1.0 && < 2.0, but you have the version 2.0 of B installed, you can compile A against B 2.0 by using `cabal install --allow-newer=B A`. This works for the whole package index: if A also depends on C that in turn depends on B < 2.0, C's dependency on B will be also relaxed. Example: ~~~~~~~~~~~~~~~~ $ cd foo $ cabal configure Resolving dependencies... cabal: Could not resolve dependencies: [...] $ cabal configure --allow-newer Resolving dependencies... Configuring foo... ~~~~~~~~~~~~~~~~ Additional examples: ~~~~~~~~~~~~~~~~ # Relax upper bounds in all dependencies. $ cabal install --allow-newer foo # Relax upper bounds only in dependencies on bar, baz and quux. $ cabal install --allow-newer=bar,baz,quux foo # Relax the upper bound on bar and force bar==2.1. $ cabal install --allow-newer=bar --constraint="bar==2.1" foo ~~~~~~~~~~~~~~~~ It's also possible to enable `--allow-newer` permanently by setting `allow-newer: True` in the `~/.cabal/config` file. `--constraint=`_constraint_ : Restrict solutions involving a package to a given version range. For example, `cabal install --constraint="bar==2.1"` will only consider install plans that do not use `bar` at all, or `bar` of version 2.1. As a special case, `cabal install --constraint="bar -none"` prevents `bar` from being used at all (`-none` abbreviates `> 1 && < 1`); `cabal install --constraint="bar installed"` prevents reinstallation of the `bar` package; `cabal install --constraint="bar +foo -baz"` specifies that the flag `foo` should be turned on and the `baz` flag should be turned off. ## setup build ## Perform any preprocessing or compilation needed to make this package ready for installation. This command takes the following options: --_prog_-options=_options_, --_prog_-option=_option_ : These are mostly the same as the [options configure step](#setup-configure). Unlike the options specified at the configure step, any program options specified at the build step are not persistent but are used for that invocation only. They options specified at the build step are in addition not in replacement of any options specified at the configure step. ## setup haddock ## Build the documentation for the package using [haddock][]. By default, only the documentation for the exposed modules is generated (but see the `--executables` and `--internal` flags below). This command takes the following options: `--hoogle` : Generate a file `dist/doc/html/`_pkgid_`.txt`, which can be converted by [Hoogle](http://www.haskell.org/hoogle/) into a database for searching. This is equivalent to running [haddock][] with the `--hoogle` flag. `--html-location=`_url_ : Specify a template for the location of HTML documentation for prerequisite packages. The substitutions ([see listing](#paths-in-the-simple-build-system)) are applied to the template to obtain a location for each package, which will be used by hyperlinks in the generated documentation. For example, the following command generates links pointing at [Hackage] pages: > setup haddock --html-location='http://hackage.haskell.org/packages/archive/$pkg/latest/doc/html' Here the argument is quoted to prevent substitution by the shell. If this option is omitted, the location for each package is obtained using the package tool (e.g. `ghc-pkg`). `--executables` : Also run [haddock][] for the modules of all the executable programs. By default [haddock][] is run only on the exported modules. `--internal` : Run [haddock][] for the all modules, including unexposed ones, and make [haddock][] generate documentation for unexported symbols as well. `--css=`_path_ : The argument _path_ denotes a CSS file, which is passed to [haddock][] and used to set the style of the generated documentation. This is only needed to override the default style that [haddock][] uses. `--hyperlink-source` : Generate [haddock][] documentation integrated with [HsColour][]. First, [HsColour][] is run to generate colourised code. Then [haddock][] is run to generate HTML documentation. Each entity shown in the documentation is linked to its definition in the colourised code. `--hscolour-css=`_path_ : The argument _path_ denotes a CSS file, which is passed to [HsColour][] as in > runhaskell Setup.hs hscolour --css=_path_ ## setup hscolour ## Produce colourised code in HTML format using [HsColour][]. Colourised code for exported modules is put in `dist/doc/html/`_pkgid_`/src`. This command takes the following options: `--executables` : Also run [HsColour][] on the sources of all executable programs. Colourised code is put in `dist/doc/html/`_pkgid_/_executable_`/src`. `--css=`_path_ : Use the given CSS file for the generated HTML files. The CSS file defines the colours used to colourise code. Note that this copies the given CSS file to the directory with the generated HTML files (renamed to `hscolour.css`) rather than linking to it. ## setup install ## Copy the files into the install locations and (for library packages) register the package with the compiler, i.e. make the modules it contains available to programs. The [install locations](#installation-paths) are determined by options to `setup configure`. This command takes the following options: `--global` : Register this package in the system-wide database. (This is the default, unless the `--user` option was supplied to the `configure` command.) `--user` : Register this package in the user's local package database. (This is the default if the `--user` option was supplied to the `configure` command.) ## setup copy ## Copy the files without registering them. This command is mainly of use to those creating binary packages. This command takes the following option: `--destdir=`_path_ Specify the directory under which to place installed files. If this is not given, then the root directory is assumed. ## setup register ## Register this package with the compiler, i.e. make the modules it contains available to programs. This only makes sense for library packages. Note that the `install` command incorporates this action. The main use of this separate command is in the post-installation step for a binary package. This command takes the following options: `--global` : Register this package in the system-wide database. (This is the default.) `--user` : Register this package in the user's local package database. `--gen-script` : Instead of registering the package, generate a script containing commands to perform the registration. On Unix, this file is called `register.sh`, on Windows, `register.bat`. This script might be included in a binary bundle, to be run after the bundle is unpacked on the target system. `--gen-pkg-config`[=_path_] : Instead of registering the package, generate a package registration file. This only applies to compilers that support package registration files which at the moment is only GHC. The file should be used with the compiler's mechanism for registering packages. This option is mainly intended for packaging systems. If possible use the `--gen-script` option instead since it is more portable across Haskell implementations. The _path_ is optional and can be used to specify a particular output file to generate. Otherwise, by default the file is the package name and version with a `.conf` extension. `--inplace` : Registers the package for use directly from the build tree, without needing to install it. This can be useful for testing: there's no need to install the package after modifying it, just recompile and test. This flag does not create a build-tree-local package database. It still registers the package in one of the user or global databases. However, there are some caveats. It only works with GHC (currently). It only works if your package doesn't depend on having any supplemental files installed --- plain Haskell libraries should be fine. ## setup unregister ## Deregister this package with the compiler. This command takes the following options: `--global` : Deregister this package in the system-wide database. (This is the default.) `--user` : Deregister this package in the user's local package database. `--gen-script` : Instead of deregistering the package, generate a script containing commands to perform the deregistration. On Unix, this file is called `unregister.sh`, on Windows, `unregister.bat`. This script might be included in a binary bundle, to be run on the target system. ## setup clean ## Remove any local files created during the `configure`, `build`, `haddock`, `register` or `unregister` steps, and also any files and directories listed in the `extra-tmp-files` field. This command takes the following options: `--save-configure` or `-s` : Keeps the configuration information so it is not necessary to run the configure step again before building. ## setup test ## Run the test suites specified in the package description file. Aside from the following flags, Cabal accepts the name of one or more test suites on the command line after `test`. When supplied, Cabal will run only the named test suites, otherwise, Cabal will run all test suites in the package. `--builddir=`_dir_ : The directory where Cabal puts generated build files (default: `dist`). Test logs will be located in the `test` subdirectory. `--human-log=`_path_ : The template used to name human-readable test logs; the path is relative to `dist/test`. By default, logs are named according to the template `$pkgid-$test-suite.log`, so that each test suite will be logged to its own human-readable log file. Template variables allowed are: `$pkgid`, `$compiler`, `$os`, `$arch`, `$abi`, `$abitag`, `$test-suite`, and `$result`. `--machine-log=`_path_ : The path to the machine-readable log, relative to `dist/test`. The default template is `$pkgid.log`. Template variables allowed are: `$pkgid`, `$compiler`, `$os`, `$arch`, `$abi`, `$abitag` and `$result`. `--show-details=`_filter_ : Determines if the results of individual test cases are shown on the terminal. May be `always` (always show), `never` (never show), `failures` (show only failed results), or `streaming` (show all results in real time). `--test-options=`_options_ : Give extra options to the test executables. `--test-option=`_option_ : give an extra option to the test executables. There is no need to quote options containing spaces because a single option is assumed, so options will not be split on spaces. ## setup sdist ## Create a system- and compiler-independent source distribution in a file _package_-_version_`.tar.gz` in the `dist` subdirectory, for distribution to package builders. When unpacked, the commands listed in this section will be available. The files placed in this distribution are the package description file, the setup script, the sources of the modules named in the package description file, and files named in the `license-file`, `main-is`, `c-sources`, `js-sources`, `data-files`, `extra-source-files` and `extra-doc-files` fields. This command takes the following option: `--snapshot` : Append today's date (in "YYYYMMDD" format) to the version number for the generated source package. The original package is unaffected. [dist-simple]: ../release/cabal-latest/doc/API/Cabal/Distribution-Simple.html [dist-make]: ../release/cabal-latest/doc/API/Cabal/Distribution-Make.html [dist-license]: ../release/cabal-latest/doc/API/Cabal/Distribution-License.html#t:License [extension]: ../release/cabal-latest/doc/API/Cabal/Language-Haskell-Extension.html#t:Extension [BuildType]: ../release/cabal-latest/doc/API/Cabal/Distribution-PackageDescription.html#t:BuildType [alex]: http://www.haskell.org/alex/ [autoconf]: http://www.gnu.org/software/autoconf/ [c2hs]: http://www.cse.unsw.edu.au/~chak/haskell/c2hs/ [cpphs]: http://projects.haskell.org/cpphs/ [greencard]: http://hackage.haskell.org/package/greencard [haddock]: http://www.haskell.org/haddock/ [HsColour]: http://www.cs.york.ac.uk/fp/darcs/hscolour/ [happy]: http://www.haskell.org/happy/ [Hackage]: http://hackage.haskell.org/ [pkg-config]: http://www.freedesktop.org/wiki/Software/pkg-config/ Cabal-1.22.5.0/doc/misc.markdown0000644000000000000000000000746012627136221014404 0ustar0000000000000000% Cabal User Guide # Reporting bugs and deficiencies # Please report any flaws or feature requests in the [bug tracker][]. For general discussion or queries email the libraries mailing list . There is also a development mailing list . [bug tracker]: https://github.com/haskell/cabal/issues # Stability of Cabal interfaces # The Cabal library and related infrastructure is still under active development. New features are being added and limitations and bugs are being fixed. This requires internal changes and often user visible changes as well. We therefore cannot promise complete future-proof stability, at least not without halting all development work. This section documents the aspects of the Cabal interface that we can promise to keep stable and which bits are subject to change. ## Cabal file format ## This is backwards compatible and mostly forwards compatible. New fields can be added without breaking older versions of Cabal. Fields can be deprecated without breaking older packages. ## Command-line interface ## ### Very Stable Command-line interfaces ### * `./setup configure` * `--prefix` * `--user` * `--ghc`, `--uhc` * `--verbose` * `--prefix` * `./setup build` * `./setup install` * `./setup register` * `./setup copy` ### Stable Command-line interfaces ### ### Unstable command-line ### ## Functions and Types ## The Cabal library follows the [Package Versioning Policy][PVP]. This means that within a stable major release, for example 1.2.x, there will be no incompatible API changes. But minor versions increments, for example 1.2.3, indicate compatible API additions. The Package Versioning Policy does not require any API guarantees between major releases, for example between 1.2.x and 1.4.x. In practise of course not everything changes between major releases. Some parts of the API are more prone to change than others. The rest of this section gives some informal advice on what level of API stability you can expect between major releases. [PVP]: http://www.haskell.org/haskellwiki/Package_versioning_policy ### Very Stable API ### * `defaultMain` * `defaultMainWithHooks defaultUserHooks` But regular `defaultMainWithHooks` isn't stable since `UserHooks` changes. ### Semi-stable API ### * `UserHooks` The hooks API will change in the future * `Distribution.*` is mostly declarative information about packages and is somewhat stable. ### Unstable API ### Everything under `Distribution.Simple.*` has no stability guarantee. ## Hackage ## The index format is a partly stable interface. It consists of a tar.gz file that contains directories with `.cabal` files in. In future it may contain more kinds of files so do not assume every file is a `.cabal` file. Incompatible revisions to the format would involve bumping the name of the index file, i.e., `00-index.tar.gz`, `01-index.tar.gz` etc. [dist-simple]: ../release/cabal-latest/doc/API/Cabal/Distribution-Simple.html [dist-make]: ../release/cabal-latest/doc/API/Cabal/Distribution-Make.html [dist-license]: ../release/cabal-latest/doc/API/Cabal/Distribution-License.html#t:License [extension]: ../release/cabal-latest/doc/API/Cabal/Language-Haskell-Extension.html#t:Extension [BuildType]: ../release/cabal-latest/doc/API/Cabal/Distribution-PackageDescription.html#t:BuildType [alex]: http://www.haskell.org/alex/ [autoconf]: http://www.gnu.org/software/autoconf/ [c2hs]: http://www.cse.unsw.edu.au/~chak/haskell/c2hs/ [cpphs]: http://projects.haskell.org/cpphs/ [greencard]: http://hackage.haskell.org/package/greencard [haddock]: http://www.haskell.org/haddock/ [HsColour]: http://www.cs.york.ac.uk/fp/darcs/hscolour/ [happy]: http://www.haskell.org/happy/ [Hackage]: http://hackage.haskell.org/ [pkg-config]: http://www.freedesktop.org/wiki/Software/pkg-config/ Cabal-1.22.5.0/Language/0000755000000000000000000000000012627136220012653 5ustar0000000000000000Cabal-1.22.5.0/Language/Haskell/0000755000000000000000000000000012627136220014236 5ustar0000000000000000Cabal-1.22.5.0/Language/Haskell/Extension.hs0000644000000000000000000007176712627136220016570 0ustar0000000000000000{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-} ----------------------------------------------------------------------------- -- | -- Module : Language.Haskell.Extension -- Copyright : Isaac Jones 2003-2004 -- License : BSD3 -- -- Maintainer : libraries@haskell.org -- Portability : portable -- -- Haskell language dialects and extensions module Language.Haskell.Extension ( Language(..), knownLanguages, Extension(..), KnownExtension(..), knownExtensions, deprecatedExtensions ) where import Distribution.Text (Text(..)) import qualified Distribution.Compat.ReadP as Parse import qualified Text.PrettyPrint as Disp import qualified Data.Char as Char (isAlphaNum) import Data.Array (Array, accumArray, bounds, Ix(inRange), (!)) import Distribution.Compat.Binary (Binary) import Data.Data (Data) import Data.Typeable (Typeable) import GHC.Generics (Generic) -- ------------------------------------------------------------ -- * Language -- ------------------------------------------------------------ -- | This represents a Haskell language dialect. -- -- Language 'Extension's are interpreted relative to one of these base -- languages. -- data Language = -- | The Haskell 98 language as defined by the Haskell 98 report. -- Haskell98 -- | The Haskell 2010 language as defined by the Haskell 2010 report. -- | Haskell2010 -- | An unknown language, identified by its name. | UnknownLanguage String deriving (Generic, Show, Read, Eq, Typeable, Data) instance Binary Language knownLanguages :: [Language] knownLanguages = [Haskell98, Haskell2010] instance Text Language where disp (UnknownLanguage other) = Disp.text other disp other = Disp.text (show other) parse = do lang <- Parse.munch1 Char.isAlphaNum return (classifyLanguage lang) classifyLanguage :: String -> Language classifyLanguage = \str -> case lookup str langTable of Just lang -> lang Nothing -> UnknownLanguage str where langTable = [ (show lang, lang) | lang <- knownLanguages ] -- ------------------------------------------------------------ -- * Extension -- ------------------------------------------------------------ -- Note: if you add a new 'KnownExtension': -- -- * also add it to the Distribution.Simple.X.languageExtensions lists -- (where X is each compiler: GHC, JHC, LHC, UHC, HaskellSuite) -- -- | This represents language extensions beyond a base 'Language' definition -- (such as 'Haskell98') that are supported by some implementations, usually -- in some special mode. -- -- Where applicable, references are given to an implementation's -- official documentation. data Extension = -- | Enable a known extension EnableExtension KnownExtension -- | Disable a known extension | DisableExtension KnownExtension -- | An unknown extension, identified by the name of its @LANGUAGE@ -- pragma. | UnknownExtension String deriving (Generic, Show, Read, Eq, Ord, Typeable, Data) instance Binary Extension data KnownExtension = -- | Allow overlapping class instances, provided there is a unique -- most specific instance for each use. -- -- * OverlappingInstances -- | Ignore structural rules guaranteeing the termination of class -- instance resolution. Termination is guaranteed by a fixed-depth -- recursion stack, and compilation may fail if this depth is -- exceeded. -- -- * | UndecidableInstances -- | Implies 'OverlappingInstances'. Allow the implementation to -- choose an instance even when it is possible that further -- instantiation of types will lead to a more specific instance -- being applicable. -- -- * | IncoherentInstances -- | /(deprecated)/ Allow recursive bindings in @do@ blocks, using the @rec@ -- keyword. See also 'RecursiveDo'. | DoRec -- | Allow recursive bindings using @mdo@, a variant of @do@. -- @DoRec@ provides a different, preferred syntax. -- -- * | RecursiveDo -- | Provide syntax for writing list comprehensions which iterate -- over several lists together, like the 'zipWith' family of -- functions. -- -- * | ParallelListComp -- | Allow multiple parameters in a type class. -- -- * | MultiParamTypeClasses -- | Enable the dreaded monomorphism restriction. -- -- * | MonomorphismRestriction -- | Allow a specification attached to a multi-parameter type class -- which indicates that some parameters are entirely determined by -- others. The implementation will check that this property holds -- for the declared instances, and will use this property to reduce -- ambiguity in instance resolution. -- -- * | FunctionalDependencies -- | Like 'RankNTypes' but does not allow a higher-rank type to -- itself appear on the left of a function arrow. -- -- * | Rank2Types -- | Allow a universally-quantified type to occur on the left of a -- function arrow. -- -- * | RankNTypes -- | Allow data constructors to have polymorphic arguments. Unlike -- 'RankNTypes', does not allow this for ordinary functions. -- -- * | PolymorphicComponents -- | Allow existentially-quantified data constructors. -- -- * | ExistentialQuantification -- | Cause a type variable in a signature, which has an explicit -- @forall@ quantifier, to scope over the definition of the -- accompanying value declaration. -- -- * | ScopedTypeVariables -- | Deprecated, use 'ScopedTypeVariables' instead. | PatternSignatures -- | Enable implicit function parameters with dynamic scope. -- -- * | ImplicitParams -- | Relax some restrictions on the form of the context of a type -- signature. -- -- * | FlexibleContexts -- | Relax some restrictions on the form of the context of an -- instance declaration. -- -- * | FlexibleInstances -- | Allow data type declarations with no constructors. -- -- * | EmptyDataDecls -- | Run the C preprocessor on Haskell source code. -- -- * | CPP -- | Allow an explicit kind signature giving the kind of types over -- which a type variable ranges. -- -- * | KindSignatures -- | Enable a form of pattern which forces evaluation before an -- attempted match, and a form of strict @let@/@where@ binding. -- -- * | BangPatterns -- | Allow type synonyms in instance heads. -- -- * | TypeSynonymInstances -- | Enable Template Haskell, a system for compile-time -- metaprogramming. -- -- * | TemplateHaskell -- | Enable the Foreign Function Interface. In GHC, implements the -- standard Haskell 98 Foreign Function Interface Addendum, plus -- some GHC-specific extensions. -- -- * | ForeignFunctionInterface -- | Enable arrow notation. -- -- * | Arrows -- | /(deprecated)/ Enable generic type classes, with default instances defined in -- terms of the algebraic structure of a type. -- -- * | Generics -- | Enable the implicit importing of the module "Prelude". When -- disabled, when desugaring certain built-in syntax into ordinary -- identifiers, use whatever is in scope rather than the "Prelude" -- -- version. -- -- * | ImplicitPrelude -- | Enable syntax for implicitly binding local names corresponding -- to the field names of a record. Puns bind specific names, unlike -- 'RecordWildCards'. -- -- * | NamedFieldPuns -- | Enable a form of guard which matches a pattern and binds -- variables. -- -- * | PatternGuards -- | Allow a type declared with @newtype@ to use @deriving@ for any -- class with an instance for the underlying type. -- -- * | GeneralizedNewtypeDeriving -- | Enable the \"Trex\" extensible records system. -- -- * | ExtensibleRecords -- | Enable type synonyms which are transparent in some definitions -- and opaque elsewhere, as a way of implementing abstract -- datatypes. -- -- * | RestrictedTypeSynonyms -- | Enable an alternate syntax for string literals, -- with string templating. -- -- * | HereDocuments -- | Allow the character @#@ as a postfix modifier on identifiers. -- Also enables literal syntax for unboxed values. -- -- * | MagicHash -- | Allow data types and type synonyms which are indexed by types, -- i.e. ad-hoc polymorphism for types. -- -- * | TypeFamilies -- | Allow a standalone declaration which invokes the type class -- @deriving@ mechanism. -- -- * | StandaloneDeriving -- | Allow certain Unicode characters to stand for certain ASCII -- character sequences, e.g. keywords and punctuation. -- -- * | UnicodeSyntax -- | Allow the use of unboxed types as foreign types, e.g. in -- @foreign import@ and @foreign export@. -- -- * | UnliftedFFITypes -- | Enable interruptible FFI. -- -- * | InterruptibleFFI -- | Allow use of CAPI FFI calling convention (@foreign import capi@). -- -- * | CApiFFI -- | Defer validity checking of types until after expanding type -- synonyms, relaxing the constraints on how synonyms may be used. -- -- * | LiberalTypeSynonyms -- | Allow the name of a type constructor, type class, or type -- variable to be an infix operator. | TypeOperators -- | Enable syntax for implicitly binding local names corresponding -- to the field names of a record. A wildcard binds all unmentioned -- names, unlike 'NamedFieldPuns'. -- -- * | RecordWildCards -- | Deprecated, use 'NamedFieldPuns' instead. | RecordPuns -- | Allow a record field name to be disambiguated by the type of -- the record it's in. -- -- * | DisambiguateRecordFields -- | Enable traditional record syntax (as supported by Haskell 98) -- -- * | TraditionalRecordSyntax -- | Enable overloading of string literals using a type class, much -- like integer literals. -- -- * | OverloadedStrings -- | Enable generalized algebraic data types, in which type -- variables may be instantiated on a per-constructor basis. Implies -- 'GADTSyntax'. -- -- * | GADTs -- | Enable GADT syntax for declaring ordinary algebraic datatypes. -- -- * | GADTSyntax -- | Make pattern bindings monomorphic. -- -- * | MonoPatBinds -- | Relax the requirements on mutually-recursive polymorphic -- functions. -- -- * | RelaxedPolyRec -- | Allow default instantiation of polymorphic types in more -- situations. -- -- * | ExtendedDefaultRules -- | Enable unboxed tuples. -- -- * | UnboxedTuples -- | Enable @deriving@ for classes 'Data.Typeable.Typeable' and -- 'Data.Generics.Data'. -- -- * | DeriveDataTypeable -- | Enable @deriving@ for 'GHC.Generics.Generic' and 'GHC.Generics.Generic1'. -- -- * | DeriveGeneric -- | Enable support for default signatures. -- -- * | DefaultSignatures -- | Allow type signatures to be specified in instance declarations. -- -- * | InstanceSigs -- | Allow a class method's type to place additional constraints on -- a class type variable. -- -- * | ConstrainedClassMethods -- | Allow imports to be qualified by the package name the module is -- intended to be imported from, e.g. -- -- > import "network" Network.Socket -- -- * | PackageImports -- | /(deprecated)/ Allow a type variable to be instantiated at a -- polymorphic type. -- -- * | ImpredicativeTypes -- | /(deprecated)/ Change the syntax for qualified infix operators. -- -- * | NewQualifiedOperators -- | Relax the interpretation of left operator sections to allow -- unary postfix operators. -- -- * | PostfixOperators -- | Enable quasi-quotation, a mechanism for defining new concrete -- syntax for expressions and patterns. -- -- * | QuasiQuotes -- | Enable generalized list comprehensions, supporting operations -- such as sorting and grouping. -- -- * | TransformListComp -- | Enable monad comprehensions, which generalise the list -- comprehension syntax to work for any monad. -- -- * | MonadComprehensions -- | Enable view patterns, which match a value by applying a -- function and matching on the result. -- -- * | ViewPatterns -- | Allow concrete XML syntax to be used in expressions and patterns, -- as per the Haskell Server Pages extension language: -- . The ideas behind it are -- discussed in the paper \"Haskell Server Pages through Dynamic Loading\" -- by Niklas Broberg, from Haskell Workshop '05. | XmlSyntax -- | Allow regular pattern matching over lists, as discussed in the -- paper \"Regular Expression Patterns\" by Niklas Broberg, Andreas Farre -- and Josef Svenningsson, from ICFP '04. | RegularPatterns -- | Enable the use of tuple sections, e.g. @(, True)@ desugars into -- @\x -> (x, True)@. -- -- * | TupleSections -- | Allow GHC primops, written in C--, to be imported into a Haskell -- file. | GHCForeignImportPrim -- | Support for patterns of the form @n + k@, where @k@ is an -- integer literal. -- -- * | NPlusKPatterns -- | Improve the layout rule when @if@ expressions are used in a @do@ -- block. | DoAndIfThenElse -- | Enable support for multi-way @if@-expressions. -- -- * | MultiWayIf -- | Enable support lambda-@case@ expressions. -- -- * | LambdaCase -- | Makes much of the Haskell sugar be desugared into calls to the -- function with a particular name that is in scope. -- -- * | RebindableSyntax -- | Make @forall@ a keyword in types, which can be used to give the -- generalisation explicitly. -- -- * | ExplicitForAll -- | Allow contexts to be put on datatypes, e.g. the @Eq a@ in -- @data Eq a => Set a = NilSet | ConsSet a (Set a)@. -- -- * | DatatypeContexts -- | Local (@let@ and @where@) bindings are monomorphic. -- -- * | MonoLocalBinds -- | Enable @deriving@ for the 'Data.Functor.Functor' class. -- -- * | DeriveFunctor -- | Enable @deriving@ for the 'Data.Traversable.Traversable' class. -- -- * | DeriveTraversable -- | Enable @deriving@ for the 'Data.Foldable.Foldable' class. -- -- * | DeriveFoldable -- | Enable non-decreasing indentation for @do@ blocks. -- -- * | NondecreasingIndentation -- | Allow imports to be qualified with a safe keyword that requires -- the imported module be trusted as according to the Safe Haskell -- definition of trust. -- -- > import safe Network.Socket -- -- * | SafeImports -- | Compile a module in the Safe, Safe Haskell mode -- a restricted -- form of the Haskell language to ensure type safety. -- -- * | Safe -- | Compile a module in the Trustworthy, Safe Haskell mode -- no -- restrictions apply but the module is marked as trusted as long as -- the package the module resides in is trusted. -- -- * | Trustworthy -- | Compile a module in the Unsafe, Safe Haskell mode so that -- modules compiled using Safe, Safe Haskell mode can't import it. -- -- * | Unsafe -- | Allow type class/implicit parameter/equality constraints to be -- used as types with the special kind constraint. Also generalise -- the @(ctxt => ty)@ syntax so that any type of kind constraint can -- occur before the arrow. -- -- * | ConstraintKinds -- | Enable kind polymorphism. -- -- * | PolyKinds -- | Enable datatype promotion. -- -- * | DataKinds -- | Enable parallel arrays syntax (@[:@, @:]@) for /Data Parallel Haskell/. -- -- * | ParallelArrays -- | Enable explicit role annotations, like in (@type role Foo representational representational@). -- -- * | RoleAnnotations -- | Enable overloading of list literals, arithmetic sequences and -- list patterns using the 'IsList' type class. -- -- * | OverloadedLists -- | Enable case expressions that have no alternatives. Also applies to lambda-case expressions if they are enabled. -- -- * | EmptyCase -- | Triggers the generation of derived 'Typeable' instances for every -- datatype and type class declaration. -- -- * | AutoDeriveTypeable -- | Desugars negative literals directly (without using negate). -- -- * | NegativeLiterals -- | Allow the use of binary integer literal syntax (e.g. @0b11001001@ to denote @201@). -- -- * | BinaryLiterals -- | Allow the use of floating literal syntax for all instances of 'Num', including 'Int' and 'Integer'. -- -- * | NumDecimals -- | Enable support for type classes with no type parameter. -- -- * | NullaryTypeClasses -- | Enable explicit namespaces in module import/export lists. -- -- * | ExplicitNamespaces -- | Allow the user to write ambiguous types, and the type inference engine to infer them. -- -- * | AllowAmbiguousTypes -- | Enable @foreign import javascript@. | JavaScriptFFI -- | Allow giving names to and abstracting over patterns. -- -- * | PatternSynonyms -- | Allow anonymous placeholders (underscore) inside type signatures. The -- type inference engine will generate a message describing the type inferred -- at the hole's location. -- -- * | PartialTypeSignatures -- | Allow named placeholders written with a leading underscore inside type -- signatures. Wildcards with the same name unify to the same type. -- -- * | NamedWildCards -- | Enable @deriving@ for any class. -- -- * | DeriveAnyClass deriving (Generic, Show, Read, Eq, Ord, Enum, Bounded, Typeable, Data) instance Binary KnownExtension {-# DEPRECATED knownExtensions "KnownExtension is an instance of Enum and Bounded, use those instead." #-} knownExtensions :: [KnownExtension] knownExtensions = [minBound..maxBound] -- | Extensions that have been deprecated, possibly paired with another -- extension that replaces it. -- deprecatedExtensions :: [(Extension, Maybe Extension)] deprecatedExtensions = [ (EnableExtension RecordPuns, Just (EnableExtension NamedFieldPuns)) , (EnableExtension PatternSignatures, Just (EnableExtension ScopedTypeVariables)) ] -- NOTE: when adding deprecated extensions that have new alternatives -- we must be careful to make sure that the deprecation messages are -- valid. We must not recommend aliases that cannot be used with older -- compilers, perhaps by adding support in Cabal to translate the new -- name to the old one for older compilers. Otherwise we are in danger -- of the scenario in ticket #689. instance Text Extension where disp (UnknownExtension other) = Disp.text other disp (EnableExtension ke) = Disp.text (show ke) disp (DisableExtension ke) = Disp.text ("No" ++ show ke) parse = do extension <- Parse.munch1 Char.isAlphaNum return (classifyExtension extension) instance Text KnownExtension where disp ke = Disp.text (show ke) parse = do extension <- Parse.munch1 Char.isAlphaNum case classifyKnownExtension extension of Just ke -> return ke Nothing -> fail ("Can't parse " ++ show extension ++ " as KnownExtension") classifyExtension :: String -> Extension classifyExtension string = case classifyKnownExtension string of Just ext -> EnableExtension ext Nothing -> case string of 'N':'o':string' -> case classifyKnownExtension string' of Just ext -> DisableExtension ext Nothing -> UnknownExtension string _ -> UnknownExtension string -- | 'read' for 'KnownExtension's is really really slow so for the Text -- instance -- what we do is make a simple table indexed off the first letter in the -- extension name. The extension names actually cover the range @'A'-'Z'@ -- pretty densely and the biggest bucket is 7 so it's not too bad. We just do -- a linear search within each bucket. -- -- This gives an order of magnitude improvement in parsing speed, and it'll -- also allow us to do case insensitive matches in future if we prefer. -- classifyKnownExtension :: String -> Maybe KnownExtension classifyKnownExtension "" = Nothing classifyKnownExtension string@(c : _) | inRange (bounds knownExtensionTable) c = lookup string (knownExtensionTable ! c) | otherwise = Nothing knownExtensionTable :: Array Char [(String, KnownExtension)] knownExtensionTable = accumArray (flip (:)) [] ('A', 'Z') [ (head str, (str, extension)) | extension <- [toEnum 0 ..] , let str = show extension ] Cabal-1.22.5.0/tests/0000755000000000000000000000000012627136221012273 5ustar0000000000000000Cabal-1.22.5.0/tests/PackageTests.hs0000644000000000000000000001774012627136220015215 0ustar0000000000000000-- The intention is that this will be the new unit test framework. -- Please add any working tests here. This file should do nothing -- but import tests from other modules. -- -- Stephen Blackheath, 2009 module Main where import PackageTests.BenchmarkExeV10.Check import PackageTests.BenchmarkOptions.Check import PackageTests.BenchmarkStanza.Check -- import PackageTests.BuildDeps.GlobalBuildDepsNotAdditive1.Check -- import PackageTests.BuildDeps.GlobalBuildDepsNotAdditive2.Check import PackageTests.BuildDeps.InternalLibrary0.Check import PackageTests.BuildDeps.InternalLibrary1.Check import PackageTests.BuildDeps.InternalLibrary2.Check import PackageTests.BuildDeps.InternalLibrary3.Check import PackageTests.BuildDeps.InternalLibrary4.Check import PackageTests.BuildDeps.SameDepsAllRound.Check import PackageTests.BuildDeps.TargetSpecificDeps1.Check import PackageTests.BuildDeps.TargetSpecificDeps2.Check import PackageTests.BuildDeps.TargetSpecificDeps3.Check import PackageTests.BuildTestSuiteDetailedV09.Check import PackageTests.PackageTester (PackageSpec(..), compileSetup) import PackageTests.PathsModule.Executable.Check import PackageTests.PathsModule.Library.Check import PackageTests.PreProcess.Check import PackageTests.TemplateHaskell.Check import PackageTests.CMain.Check import PackageTests.DeterministicAr.Check import PackageTests.EmptyLib.Check import PackageTests.Haddock.Check import PackageTests.TestOptions.Check import PackageTests.TestStanza.Check import PackageTests.TestSuiteExeV10.Check import PackageTests.OrderFlags.Check import PackageTests.ReexportedModules.Check import Distribution.Simple.Configure ( ConfigStateFileError(..), getConfigStateFile ) import Distribution.Simple.LocalBuildInfo (LocalBuildInfo(..)) import Distribution.Simple.Program.Types (programPath) import Distribution.Simple.Program.Builtin ( ghcProgram, ghcPkgProgram, haddockProgram ) import Distribution.Simple.Program.Db (requireProgram) import Distribution.Simple.Utils (cabalVersion) import Distribution.Text (display) import Distribution.Verbosity (normal) import Distribution.Version (Version(Version)) import Control.Exception (try, throw) import System.Directory ( getCurrentDirectory, setCurrentDirectory ) import System.FilePath (()) import System.IO (BufferMode(NoBuffering), hSetBuffering, stdout) import Test.Framework (Test, TestName, defaultMain, testGroup) import Test.Framework.Providers.HUnit (hUnitTestToTests) import qualified Test.HUnit as HUnit hunit :: TestName -> HUnit.Test -> Test hunit name test = testGroup name $ hUnitTestToTests test tests :: Version -> PackageSpec -> FilePath -> FilePath -> [Test] tests version inplaceSpec ghcPath ghcPkgPath = [ hunit "BuildDeps/SameDepsAllRound" (PackageTests.BuildDeps.SameDepsAllRound.Check.suite ghcPath) -- The two following tests were disabled by Johan Tibell as -- they have been failing for a long time: -- , hunit "BuildDeps/GlobalBuildDepsNotAdditive1/" -- (PackageTests.BuildDeps.GlobalBuildDepsNotAdditive1.Check.suite ghcPath) -- , hunit "BuildDeps/GlobalBuildDepsNotAdditive2/" -- (PackageTests.BuildDeps.GlobalBuildDepsNotAdditive2.Check.suite ghcPath) , hunit "BuildDeps/InternalLibrary0" (PackageTests.BuildDeps.InternalLibrary0.Check.suite version ghcPath) , hunit "PreProcess" (PackageTests.PreProcess.Check.suite ghcPath) , hunit "TestStanza" (PackageTests.TestStanza.Check.suite ghcPath) -- ^ The Test stanza test will eventually be required -- only for higher versions. , testGroup "TestSuiteExeV10" (PackageTests.TestSuiteExeV10.Check.checks ghcPath) , hunit "TestOptions" (PackageTests.TestOptions.Check.suite ghcPath) , hunit "BenchmarkStanza" (PackageTests.BenchmarkStanza.Check.suite ghcPath) -- ^ The benchmark stanza test will eventually be required -- only for higher versions. , hunit "BenchmarkExeV10/Test" (PackageTests.BenchmarkExeV10.Check.checkBenchmark ghcPath) , hunit "BenchmarkOptions" (PackageTests.BenchmarkOptions.Check.suite ghcPath) , hunit "TemplateHaskell/vanilla" (PackageTests.TemplateHaskell.Check.vanilla ghcPath) , hunit "TemplateHaskell/profiling" (PackageTests.TemplateHaskell.Check.profiling ghcPath) , hunit "PathsModule/Executable" (PackageTests.PathsModule.Executable.Check.suite ghcPath) , hunit "PathsModule/Library" (PackageTests.PathsModule.Library.Check.suite ghcPath) , hunit "DeterministicAr" (PackageTests.DeterministicAr.Check.suite ghcPath ghcPkgPath) , hunit "EmptyLib/emptyLib" (PackageTests.EmptyLib.Check.emptyLib ghcPath) , hunit "Haddock" (PackageTests.Haddock.Check.suite ghcPath) , hunit "BuildTestSuiteDetailedV09" (PackageTests.BuildTestSuiteDetailedV09.Check.suite inplaceSpec ghcPath) , hunit "OrderFlags" (PackageTests.OrderFlags.Check.suite ghcPath) , hunit "TemplateHaskell/dynamic" (PackageTests.TemplateHaskell.Check.dynamic ghcPath) , hunit "ReexportedModules" (PackageTests.ReexportedModules.Check.suite ghcPath) ] ++ -- These tests are only required to pass on cabal version >= 1.7 (if version >= Version [1, 7] [] then [ hunit "BuildDeps/TargetSpecificDeps1" (PackageTests.BuildDeps.TargetSpecificDeps1.Check.suite ghcPath) , hunit "BuildDeps/TargetSpecificDeps2" (PackageTests.BuildDeps.TargetSpecificDeps2.Check.suite ghcPath) , hunit "BuildDeps/TargetSpecificDeps3" (PackageTests.BuildDeps.TargetSpecificDeps3.Check.suite ghcPath) , hunit "BuildDeps/InternalLibrary1" (PackageTests.BuildDeps.InternalLibrary1.Check.suite ghcPath) , hunit "BuildDeps/InternalLibrary2" (PackageTests.BuildDeps.InternalLibrary2.Check.suite ghcPath ghcPkgPath) , hunit "BuildDeps/InternalLibrary3" (PackageTests.BuildDeps.InternalLibrary3.Check.suite ghcPath ghcPkgPath) , hunit "BuildDeps/InternalLibrary4" (PackageTests.BuildDeps.InternalLibrary4.Check.suite ghcPath ghcPkgPath) , hunit "PackageTests/CMain" (PackageTests.CMain.Check.checkBuild ghcPath) ] else []) main :: IO () main = do -- WORKAROUND: disable buffering on stdout to get streaming test logs -- test providers _should_ do this themselves hSetBuffering stdout NoBuffering wd <- getCurrentDirectory let dbFile = wd "dist/package.conf.inplace" inplaceSpec = PackageSpec { directory = [] , configOpts = [ "--package-db=" ++ dbFile , "--constraint=Cabal == " ++ display cabalVersion ] , distPref = Nothing } putStrLn $ "Cabal test suite - testing cabal version " ++ display cabalVersion lbi <- getPersistBuildConfig_ ("dist" "setup-config") (ghc, _) <- requireProgram normal ghcProgram (withPrograms lbi) (ghcPkg, _) <- requireProgram normal ghcPkgProgram (withPrograms lbi) (haddock, _) <- requireProgram normal haddockProgram (withPrograms lbi) let ghcPath = programPath ghc ghcPkgPath = programPath ghcPkg haddockPath = programPath haddock putStrLn $ "Using ghc: " ++ ghcPath putStrLn $ "Using ghc-pkg: " ++ ghcPkgPath putStrLn $ "Using haddock: " ++ haddockPath setCurrentDirectory "tests" -- Create a shared Setup executable to speed up Simple tests compileSetup "." ghcPath defaultMain (tests cabalVersion inplaceSpec ghcPath ghcPkgPath) -- Like Distribution.Simple.Configure.getPersistBuildConfig but -- doesn't check that the Cabal version matches, which it doesn't when -- we run Cabal's own test suite, due to bootstrapping issues. getPersistBuildConfig_ :: FilePath -> IO LocalBuildInfo getPersistBuildConfig_ filename = do eLBI <- try $ getConfigStateFile filename case eLBI of Left (ConfigStateFileBadVersion _ _ (Right lbi)) -> return lbi Left (ConfigStateFileBadVersion _ _ (Left err)) -> throw err Left err -> throw err Right lbi -> return lbi Cabal-1.22.5.0/tests/README.md0000644000000000000000000000321512627136221013553 0ustar0000000000000000Writing package tests ===================== The tests under the [PackageTests] directory define and build packages that exercise various components of Cabal. Each test case is an [HUnit] test. The entry point for the test suite, where all the test cases are listed, is [PackageTests.hs]. There are utilities for calling the stages of Cabal's build process in [PackageTests/PackageTester.hs]; have a look at an existing test case to see how they are used. It is important that package tests use the in-place version of Cabal rather than the system version. Several long-standing bugs in the test suite were caused by testing the system (rather than the newly compiled) version of Cabal. There are two places where the system Cabal can accidentally be invoked: 1. Compiling `Setup.hs`. `runghc` needs to be told about the in-place package database. This issue should be solved for all future package tests; see `compileSetup` in [PackageTests/PackageTester.hs]. 2. Compiling a package which depends on Cabal. In particular, packages with the [detailed]-type test suites depend on the Cabal library directly, so it is important that they are configured to use the in-place package database. The test suite already creates a stub `PackageSpec` for this case; see [PackageTests/BuildTestSuiteDetailedV09/Check.hs] to see how it is used. [PackageTests]: PackageTests [HUnit]: http://hackage.haskell.org/package/HUnit [PackageTests.hs]: PackageTests.hs [PackageTests/PackageTester.hs]: PackageTests/PackageTester.hs [detailed]: ../Distribution/TestSuite.hs [PackageTests/BuildTestSuiteDetailedV09/Check.hs]: PackageTests/BuildTestSuiteDetailedV09/Check.hsCabal-1.22.5.0/tests/Setup.hs0000644000000000000000000000005712627136221013731 0ustar0000000000000000import Distribution.Simple main = defaultMain Cabal-1.22.5.0/tests/UnitTests.hs0000644000000000000000000000146712627136221014601 0ustar0000000000000000module Main ( main ) where import System.IO (BufferMode(NoBuffering), hSetBuffering, stdout) import Test.Framework import qualified UnitTests.Distribution.Compat.CreatePipe import qualified UnitTests.Distribution.Compat.ReadP import qualified UnitTests.Distribution.Utils.NubList tests :: [Test] tests = [ testGroup "Distribution.Compat.ReadP" UnitTests.Distribution.Compat.ReadP.tests , testGroup "Distribution.Compat.CreatePipe" UnitTests.Distribution.Compat.CreatePipe.tests , testGroup "Distribution.Utils.NubList" UnitTests.Distribution.Utils.NubList.tests ] main :: IO () main = do -- WORKAROUND: disable buffering on stdout to get streaming test logs -- test providers _should_ do this themselves hSetBuffering stdout NoBuffering defaultMain tests Cabal-1.22.5.0/tests/hackage/0000755000000000000000000000000012627136222013657 5ustar0000000000000000Cabal-1.22.5.0/tests/hackage/check.sh0000644000000000000000000000116012627136221015265 0ustar0000000000000000#!/bin/sh base_version=1.4.0.2 test_version=1.5.6 for setup in archive/*/*/Setup.hs archive/*/*/Setup.lhs; do pkgname=$(basename ${setup}) if test $(wc -w < ${setup}) -gt 21; then if ghc -package Cabal-${base_version} -S ${setup} -o /dev/null 2> /dev/null; then if ghc -package Cabal-${test_version} -S ${setup} -o /dev/null 2> /dev/null; then echo "OK ${setup}" else echo "FAIL ${setup} does not compile with Cabal-${test_version}" fi else echo "OK ${setup} (does not compile with Cabal-${base_version})" fi else echo "trivial ${setup}" fi done Cabal-1.22.5.0/tests/hackage/download.sh0000644000000000000000000000065212627136221016024 0ustar0000000000000000#!/bin/sh if test ! -f archive/archive.tar; then wget http://hackage.haskell.org/cgi-bin/hackage-scripts/archive.tar mkdir -p archive mv archive.tar archive/ tar -C archive -xf archive/archive.tar fi if test ! -f archive/00-index.tar.gz; then wget http://hackage.haskell.org/packages/archive/00-index.tar.gz mkdir -p archive mv 00-index.tar.gz archive/ tar -C archive -xzf archive/00-index.tar.gz fi Cabal-1.22.5.0/tests/hackage/unpack.sh0000644000000000000000000000072512627136222015500 0ustar0000000000000000#!/bin/sh for tarball in archive/*/*/*.tar.gz; do pkgdir=$(dirname ${tarball}) pkgname=$(basename ${tarball} .tar.gz) if tar -tzf ${tarball} ${pkgname}/Setup.hs 2> /dev/null; then tar -xzf ${tarball} ${pkgname}/Setup.hs -O > ${pkgdir}/Setup.hs elif tar -tzf ${tarball} ${pkgname}/Setup.lhs 2> /dev/null; then tar -xzf ${tarball} ${pkgname}/Setup.lhs -O > ${pkgdir}/Setup.lhs else echo "${pkgname} has no Setup.hs or .lhs at all!!?!" fi done Cabal-1.22.5.0/tests/misc/0000755000000000000000000000000012627136222013227 5ustar0000000000000000Cabal-1.22.5.0/tests/misc/ghc-supported-languages.hs0000644000000000000000000000674112627136222020323 0ustar0000000000000000-- | A test program to check that ghc has got all of its extensions registered -- module Main where import Language.Haskell.Extension import Distribution.Text import Distribution.Simple.Utils import Distribution.Verbosity import Data.List ((\\)) import Data.Maybe import Control.Applicative import Control.Monad import System.Environment import System.Exit -- | A list of GHC extensions that are deliberately not registered, -- e.g. due to being experimental and not ready for public consumption -- exceptions = map readExtension [] checkProblems :: [Extension] -> [String] checkProblems implemented = let unregistered = [ ext | ext <- implemented -- extensions that ghc knows about , not (registered ext) -- but that are not registered , ext `notElem` exceptions ] -- except for the exceptions -- check if someone has forgotten to update the exceptions list... -- exceptions that are not implemented badExceptions = exceptions \\ implemented -- exceptions that are now registered badExceptions' = filter registered exceptions in catMaybes [ check unregistered $ unlines [ "The following extensions are known to GHC but are not in the " , "extension registry in Language.Haskell.Extension." , " " ++ intercalate "\n " (map display unregistered) , "If these extensions are ready for public consumption then they " , "should be registered. If they are still experimental and you " , "think they are not ready to be registered then please add them " , "to the exceptions list in this test program along with an " , "explanation." ] , check badExceptions $ unlines [ "Error in the extension exception list. The following extensions" , "are listed as exceptions but are not even implemented by GHC:" , " " ++ intercalate "\n " (map display badExceptions) , "Please fix this test program by correcting the list of" , "exceptions." ] , check badExceptions' $ unlines [ "Error in the extension exception list. The following extensions" , "are listed as exceptions to registration but they are in fact" , "now registered in Language.Haskell.Extension:" , " " ++ intercalate "\n " (map display badExceptions') , "Please fix this test program by correcting the list of" , "exceptions." ] ] where registered (UnknownExtension _) = False registered _ = True check [] _ = Nothing check _ i = Just i main = topHandler $ do [ghcPath] <- getArgs exts <- getExtensions ghcPath let problems = checkProblems exts putStrLn (intercalate "\n" problems) if null problems then exitSuccess else exitFailure getExtensions :: FilePath -> IO [Extension] getExtensions ghcPath = map readExtension . lines <$> rawSystemStdout normal ghcPath ["--supported-languages"] readExtension :: String -> Extension readExtension str = handleNoParse $ do -- GHC defines extensions in a positive way, Cabal defines them -- relative to H98 so we try parsing ("No" ++ extName) first ext <- simpleParse ("No" ++ str) case ext of UnknownExtension _ -> simpleParse str _ -> return ext where handleNoParse :: Maybe Extension -> Extension handleNoParse = fromMaybe (error $ "unparsable extension " ++ show str) Cabal-1.22.5.0/tests/PackageTests/0000755000000000000000000000000012627136221014651 5ustar0000000000000000Cabal-1.22.5.0/tests/PackageTests/PackageTester.hs0000644000000000000000000002457412627136221017743 0ustar0000000000000000{-# LANGUAGE ScopedTypeVariables #-} -- You can set the following VERBOSE environment variable to control -- the verbosity of the output generated by this module. module PackageTests.PackageTester ( PackageSpec(..) , Success(..) , Result(..) -- * Running cabal commands , cabal_configure , cabal_build , cabal_haddock , cabal_test , cabal_bench , cabal_install , unregister , compileSetup , run -- * Test helpers , assertBuildSucceeded , assertBuildFailed , assertHaddockSucceeded , assertTestSucceeded , assertInstallSucceeded , assertOutputContains , assertOutputDoesNotContain ) where import qualified Control.Exception.Extensible as E import Control.Monad import qualified Data.ByteString.Char8 as C import Data.List import Data.Maybe import System.Directory (canonicalizePath, doesFileExist, getCurrentDirectory) import System.Environment (getEnv) import System.Exit (ExitCode(ExitSuccess)) import System.FilePath import System.IO (hIsEOF, hGetChar, hClose) import System.IO.Error (isDoesNotExistError) import System.Process (runProcess, waitForProcess) import Test.HUnit (Assertion, assertFailure) import Distribution.Compat.CreatePipe (createPipe) import Distribution.Simple.BuildPaths (exeExtension) import Distribution.Simple.Program.Run (getEffectiveEnvironment) import Distribution.Simple.Utils (printRawCommandAndArgsAndEnv) import Distribution.ReadE (readEOrFail) import Distribution.Verbosity (Verbosity, flagToVerbosity, normal) data PackageSpec = PackageSpec { directory :: FilePath , distPref :: Maybe FilePath , configOpts :: [String] } data Success = Failure | ConfigureSuccess | BuildSuccess | HaddockSuccess | InstallSuccess | TestSuccess | BenchSuccess deriving (Eq, Show) data Result = Result { successful :: Bool , success :: Success , outputText :: String } deriving Show nullResult :: Result nullResult = Result True Failure "" ------------------------------------------------------------------------ -- * Running cabal commands recordRun :: (String, ExitCode, String) -> Success -> Result -> Result recordRun (cmd, exitCode, exeOutput) thisSucc res = res { successful = successful res && exitCode == ExitSuccess , success = if exitCode == ExitSuccess then thisSucc else success res , outputText = (if null $ outputText res then "" else outputText res ++ "\n") ++ cmd ++ "\n" ++ exeOutput } cabal_configure :: PackageSpec -> FilePath -> IO Result cabal_configure spec ghcPath = do res <- doCabalConfigure spec ghcPath record spec res return res doCabalConfigure :: PackageSpec -> FilePath -> IO Result doCabalConfigure spec ghcPath = do cleanResult@(_, _, _) <- cabal spec [] ["clean"] ghcPath requireSuccess cleanResult res <- cabal spec [] (["configure", "--user", "-w", ghcPath] ++ configOpts spec) ghcPath return $ recordRun res ConfigureSuccess nullResult doCabalBuild :: PackageSpec -> FilePath -> IO Result doCabalBuild spec ghcPath = do configResult <- doCabalConfigure spec ghcPath if successful configResult then do res <- cabal spec [] ["build", "-v"] ghcPath return $ recordRun res BuildSuccess configResult else return configResult cabal_build :: PackageSpec -> FilePath -> IO Result cabal_build spec ghcPath = do res <- doCabalBuild spec ghcPath record spec res return res cabal_haddock :: PackageSpec -> [String] -> FilePath -> IO Result cabal_haddock spec extraArgs ghcPath = do res <- doCabalHaddock spec extraArgs ghcPath record spec res return res doCabalHaddock :: PackageSpec -> [String] -> FilePath -> IO Result doCabalHaddock spec extraArgs ghcPath = do configResult <- doCabalConfigure spec ghcPath if successful configResult then do res <- cabal spec [] ("haddock" : extraArgs) ghcPath return $ recordRun res HaddockSuccess configResult else return configResult unregister :: String -> FilePath -> IO () unregister libraryName ghcPkgPath = do res@(_, _, output) <- run Nothing ghcPkgPath [] ["unregister", "--user", libraryName] if "cannot find package" `isInfixOf` output then return () else requireSuccess res -- | Install this library in the user area cabal_install :: PackageSpec -> FilePath -> IO Result cabal_install spec ghcPath = do buildResult <- doCabalBuild spec ghcPath res <- if successful buildResult then do res <- cabal spec [] ["install"] ghcPath return $ recordRun res InstallSuccess buildResult else return buildResult record spec res return res cabal_test :: PackageSpec -> [(String, Maybe String)] -> [String] -> FilePath -> IO Result cabal_test spec envOverrides extraArgs ghcPath = do res <- cabal spec envOverrides ("test" : extraArgs) ghcPath let r = recordRun res TestSuccess nullResult record spec r return r cabal_bench :: PackageSpec -> [String] -> FilePath -> IO Result cabal_bench spec extraArgs ghcPath = do res <- cabal spec [] ("bench" : extraArgs) ghcPath let r = recordRun res BenchSuccess nullResult record spec r return r compileSetup :: FilePath -> FilePath -> IO () compileSetup packageDir ghcPath = do wd <- getCurrentDirectory r <- run (Just $ packageDir) ghcPath [] [ "--make" -- HPC causes trouble -- see #1012 -- , "-fhpc" , "-package-conf " ++ wd "../dist/package.conf.inplace" , "Setup.hs" ] requireSuccess r -- | Returns the command that was issued, the return code, and the output text. cabal :: PackageSpec -> [(String, Maybe String)] -> [String] -> FilePath -> IO (String, ExitCode, String) cabal spec envOverrides cabalArgs_ ghcPath = do let cabalArgs = case distPref spec of Nothing -> cabalArgs_ Just dist -> ("--builddir=" ++ dist) : cabalArgs_ customSetup <- doesFileExist (directory spec "Setup.hs") if customSetup then do compileSetup (directory spec) ghcPath path <- canonicalizePath $ directory spec "Setup" run (Just $ directory spec) path envOverrides cabalArgs else do -- Use shared Setup executable (only for Simple build types). path <- canonicalizePath "Setup" run (Just $ directory spec) path envOverrides cabalArgs -- | Returns the command that was issued, the return code, and the output text run :: Maybe FilePath -> String -> [(String, Maybe String)] -> [String] -> IO (String, ExitCode, String) run cwd path envOverrides args = do verbosity <- getVerbosity -- path is relative to the current directory; canonicalizePath makes it -- absolute, so that runProcess will find it even when changing directory. path' <- do pathExists <- doesFileExist path canonicalizePath (if pathExists then path else path <.> exeExtension) menv <- getEffectiveEnvironment envOverrides printRawCommandAndArgsAndEnv verbosity path' args menv (readh, writeh) <- createPipe pid <- runProcess path' args cwd menv Nothing (Just writeh) (Just writeh) -- fork off a thread to start consuming the output out <- suckH [] readh hClose readh -- wait for the program to terminate exitcode <- waitForProcess pid let fullCmd = unwords (path' : args) return ("\"" ++ fullCmd ++ "\" in " ++ fromMaybe "" cwd, exitcode, out) where suckH output h = do eof <- hIsEOF h if eof then return (reverse output) else do c <- hGetChar h suckH (c:output) h requireSuccess :: (String, ExitCode, String) -> IO () requireSuccess (cmd, exitCode, output) = unless (exitCode == ExitSuccess) $ assertFailure $ "Command " ++ cmd ++ " failed.\n" ++ "output: " ++ output record :: PackageSpec -> Result -> IO () record spec res = do C.writeFile (directory spec "test-log.txt") (C.pack $ outputText res) ------------------------------------------------------------------------ -- * Test helpers assertBuildSucceeded :: Result -> Assertion assertBuildSucceeded result = unless (successful result) $ assertFailure $ "expected: \'setup build\' should succeed\n" ++ " output: " ++ outputText result assertBuildFailed :: Result -> Assertion assertBuildFailed result = when (successful result) $ assertFailure $ "expected: \'setup build\' should fail\n" ++ " output: " ++ outputText result assertHaddockSucceeded :: Result -> Assertion assertHaddockSucceeded result = unless (successful result) $ assertFailure $ "expected: \'setup haddock\' should succeed\n" ++ " output: " ++ outputText result assertTestSucceeded :: Result -> Assertion assertTestSucceeded result = unless (successful result) $ assertFailure $ "expected: \'setup test\' should succeed\n" ++ " output: " ++ outputText result assertInstallSucceeded :: Result -> Assertion assertInstallSucceeded result = unless (successful result) $ assertFailure $ "expected: \'setup install\' should succeed\n" ++ " output: " ++ outputText result assertOutputContains :: String -> Result -> Assertion assertOutputContains needle result = unless (needle `isInfixOf` (concatOutput output)) $ assertFailure $ " expected: " ++ needle ++ "\n" ++ " in output: " ++ output ++ "" where output = outputText result assertOutputDoesNotContain :: String -> Result -> Assertion assertOutputDoesNotContain needle result = when (needle `isInfixOf` (concatOutput output)) $ assertFailure $ "unexpected: " ++ needle ++ " in output: " ++ output where output = outputText result -- | Replace line breaks with spaces, correctly handling "\r\n". concatOutput :: String -> String concatOutput = unwords . lines . filter ((/=) '\r') ------------------------------------------------------------------------ -- Verbosity lookupEnv :: String -> IO (Maybe String) lookupEnv name = (fmap Just $ getEnv name) `E.catch` \ (e :: IOError) -> if isDoesNotExistError e then return Nothing else E.throw e -- TODO: Convert to a "-v" flag instead. getVerbosity :: IO Verbosity getVerbosity = do maybe normal (readEOrFail flagToVerbosity) `fmap` lookupEnv "VERBOSE" Cabal-1.22.5.0/tests/PackageTests/BenchmarkExeV10/0000755000000000000000000000000012627136221017474 5ustar0000000000000000Cabal-1.22.5.0/tests/PackageTests/BenchmarkExeV10/Check.hs0000644000000000000000000000066412627136220021052 0ustar0000000000000000module PackageTests.BenchmarkExeV10.Check ( checkBenchmark ) where import PackageTests.PackageTester import System.FilePath import Test.HUnit dir :: FilePath dir = "PackageTests" "BenchmarkExeV10" checkBenchmark :: FilePath -> Test checkBenchmark ghcPath = TestCase $ do let spec = PackageSpec dir Nothing ["--enable-benchmarks"] buildResult <- cabal_build spec ghcPath assertBuildSucceeded buildResult Cabal-1.22.5.0/tests/PackageTests/BenchmarkExeV10/Foo.hs0000644000000000000000000000007712627136221020557 0ustar0000000000000000module Foo where fooTest :: [String] -> Bool fooTest _ = True Cabal-1.22.5.0/tests/PackageTests/BenchmarkExeV10/my.cabal0000644000000000000000000000047212627136221021110 0ustar0000000000000000name: my version: 0.1 license: BSD3 cabal-version: >= 1.9.2 build-type: Simple library exposed-modules: Foo build-depends: base benchmark bench-Foo type: exitcode-stdio-1.0 hs-source-dirs: benchmarks main-is: bench-Foo.hs build-depends: base, my Cabal-1.22.5.0/tests/PackageTests/BenchmarkExeV10/benchmarks/0000755000000000000000000000000012627136221021611 5ustar0000000000000000Cabal-1.22.5.0/tests/PackageTests/BenchmarkExeV10/benchmarks/bench-Foo.hs0000644000000000000000000000017712627136221023752 0ustar0000000000000000module Main where import Foo import System.Exit main :: IO () main | fooTest [] = exitSuccess | otherwise = exitFailure Cabal-1.22.5.0/tests/PackageTests/BenchmarkOptions/0000755000000000000000000000000012627136221020117 5ustar0000000000000000Cabal-1.22.5.0/tests/PackageTests/BenchmarkOptions/BenchmarkOptions.cabal0000644000000000000000000000067212627136221024356 0ustar0000000000000000name: BenchmarkOptions version: 0.1 license: BSD3 author: Johan Tibell stability: stable category: PackageTests build-type: Simple cabal-version: >= 1.9.2 description: Check that Cabal passes the correct test options to test suites. executable dummy main-is: test-BenchmarkOptions.hs build-depends: base benchmark test-BenchmarkOptions main-is: test-BenchmarkOptions.hs type: exitcode-stdio-1.0 build-depends: base Cabal-1.22.5.0/tests/PackageTests/BenchmarkOptions/Check.hs0000644000000000000000000000211712627136220021470 0ustar0000000000000000module PackageTests.BenchmarkOptions.Check where import PackageTests.PackageTester import System.FilePath import Test.HUnit suite :: FilePath -> Test suite ghcPath = TestCase $ do let spec = PackageSpec { directory = "PackageTests" "BenchmarkOptions" , configOpts = ["--enable-benchmarks"] , distPref = Nothing } _ <- cabal_build spec ghcPath result <- cabal_bench spec ["--benchmark-options=1 2 3"] ghcPath let message = "\"cabal bench\" did not pass the correct options to the " ++ "benchmark executable with \"--benchmark-options\"" assertEqual message True $ successful result result' <- cabal_bench spec [ "--benchmark-option=1" , "--benchmark-option=2" , "--benchmark-option=3" ] ghcPath let message' = "\"cabal bench\" did not pass the correct options to the " ++ "benchmark executable with \"--benchmark-option\"" assertEqual message' True $ successful result' Cabal-1.22.5.0/tests/PackageTests/BenchmarkOptions/test-BenchmarkOptions.hs0000644000000000000000000000041212627136221024673 0ustar0000000000000000module Main where import System.Environment ( getArgs ) import System.Exit ( exitFailure, exitSuccess ) main :: IO () main = do args <- getArgs if args == ["1", "2", "3"] then exitSuccess else putStrLn ("Got: " ++ show args) >> exitFailure Cabal-1.22.5.0/tests/PackageTests/BenchmarkStanza/0000755000000000000000000000000012627136221017724 5ustar0000000000000000Cabal-1.22.5.0/tests/PackageTests/BenchmarkStanza/Check.hs0000644000000000000000000000455612627136220021306 0ustar0000000000000000module PackageTests.BenchmarkStanza.Check where import Test.HUnit import System.FilePath import qualified Data.Map as Map import PackageTests.PackageTester import Distribution.Version import Distribution.PackageDescription.Parse ( readPackageDescription ) import Distribution.PackageDescription.Configuration ( finalizePackageDescription ) import Distribution.Package ( PackageName(..), Dependency(..) ) import Distribution.PackageDescription ( PackageDescription(..), BuildInfo(..), Benchmark(..) , BenchmarkInterface(..) , emptyBuildInfo , emptyBenchmark, defaultRenaming ) import Distribution.Verbosity (silent) import Distribution.System (buildPlatform) import Distribution.Compiler ( CompilerId(..), CompilerFlavor(..), unknownCompilerInfo, AbiTag(..) ) import Distribution.Text suite :: FilePath -> Test suite ghcPath = TestCase $ do let dir = "PackageTests" "BenchmarkStanza" pdFile = dir "my" <.> "cabal" spec = PackageSpec { directory = dir, configOpts = [], distPref = Nothing } result <- cabal_configure spec ghcPath assertOutputDoesNotContain "unknown section type" result genPD <- readPackageDescription silent pdFile let compiler = unknownCompilerInfo (CompilerId GHC $ Version [6, 12, 2] []) NoAbiTag anticipatedBenchmark = emptyBenchmark { benchmarkName = "dummy" , benchmarkInterface = BenchmarkExeV10 (Version [1,0] []) "dummy.hs" , benchmarkBuildInfo = emptyBuildInfo { targetBuildDepends = [ Dependency (PackageName "base") anyVersion ] , targetBuildRenaming = Map.singleton (PackageName "base") defaultRenaming , hsSourceDirs = ["."] } , benchmarkEnabled = False } case finalizePackageDescription [] (const True) buildPlatform compiler [] genPD of Left xs -> let depMessage = "should not have missing dependencies:\n" ++ (unlines $ map (show . disp) xs) in assertEqual depMessage True False Right (f, _) -> let gotBenchmark = head $ benchmarks f in assertEqual "parsed benchmark stanza does not match anticipated" gotBenchmark anticipatedBenchmark Cabal-1.22.5.0/tests/PackageTests/BenchmarkStanza/my.cabal0000644000000000000000000000055712627136221021344 0ustar0000000000000000name: BenchmarkStanza version: 0.1 license: BSD3 author: Johan Tibell stability: stable category: PackageTests build-type: Simple description: Check that Cabal recognizes the benchmark stanza defined below. Library exposed-modules: MyLibrary build-depends: base benchmark dummy main-is: dummy.hs type: exitcode-stdio-1.0 build-depends: baseCabal-1.22.5.0/tests/PackageTests/BuildDeps/0000755000000000000000000000000012627136220016523 5ustar0000000000000000Cabal-1.22.5.0/tests/PackageTests/BuildDeps/GlobalBuildDepsNotAdditive1/0000755000000000000000000000000012627136221023734 5ustar0000000000000000Cabal-1.22.5.0/tests/PackageTests/BuildDeps/GlobalBuildDepsNotAdditive1/Check.hs0000644000000000000000000000141412627136220025304 0ustar0000000000000000module PackageTests.BuildDeps.GlobalBuildDepsNotAdditive1.Check where import Test.HUnit import PackageTests.PackageTester import System.FilePath import Data.List import Control.Exception import Prelude hiding (catch) suite :: FilePath -> Test suite ghcPath = TestCase $ do let spec = PackageSpec ("PackageTests" "BuildDeps" "GlobalBuildDepsNotAdditive1") [] result <- cabal_build spec ghcPath do assertEqual "cabal build should fail - see test-log.txt" False (successful result) let sb = "Could not find module `Prelude'" assertBool ("cabal output should be "++show sb) $ sb `isInfixOf` outputText result `catch` \exc -> do putStrLn $ "Cabal result was "++show result throwIO (exc :: SomeException) tests/PackageTests/BuildDeps/GlobalBuildDepsNotAdditive1/GlobalBuildDepsNotAdditive1.cabal0000644000000000000000000000072312627136221032053 0ustar0000000000000000Cabal-1.22.5.0name: GlobalBuildDepsNotAdditive1 version: 0.1 license: BSD3 cabal-version: >= 1.6 author: Stephen Blackheath stability: stable category: PackageTests build-type: Simple description: If you specify 'base' in the global build dependencies, then define a library without base, it fails to find 'base' for the library. --------------------------------------- build-depends: base Library exposed-modules: MyLibrary build-depends: bytestring, old-time Cabal-1.22.5.0/tests/PackageTests/BuildDeps/GlobalBuildDepsNotAdditive1/MyLibrary.hs0000644000000000000000000000030312627136221026176 0ustar0000000000000000module MyLibrary where import qualified Data.ByteString.Char8 as C import System.Time myLibFunc :: IO () myLibFunc = do getClockTime let text = "myLibFunc" C.putStrLn $ C.pack text Cabal-1.22.5.0/tests/PackageTests/BuildDeps/GlobalBuildDepsNotAdditive2/0000755000000000000000000000000012627136221023735 5ustar0000000000000000Cabal-1.22.5.0/tests/PackageTests/BuildDeps/GlobalBuildDepsNotAdditive2/Check.hs0000644000000000000000000000141412627136220025305 0ustar0000000000000000module PackageTests.BuildDeps.GlobalBuildDepsNotAdditive2.Check where import Test.HUnit import PackageTests.PackageTester import System.FilePath import Data.List import Control.Exception import Prelude hiding (catch) suite :: FilePath -> Test suite ghcPath = TestCase $ do let spec = PackageSpec ("PackageTests" "BuildDeps" "GlobalBuildDepsNotAdditive2") [] result <- cabal_build spec ghcPath do assertEqual "cabal build should fail - see test-log.txt" False (successful result) let sb = "Could not find module `Prelude'" assertBool ("cabal output should be "++show sb) $ sb `isInfixOf` outputText result `catch` \exc -> do putStrLn $ "Cabal result was "++show result throwIO (exc :: SomeException) tests/PackageTests/BuildDeps/GlobalBuildDepsNotAdditive2/GlobalBuildDepsNotAdditive2.cabal0000644000000000000000000000073112627136221032054 0ustar0000000000000000Cabal-1.22.5.0name: GlobalBuildDepsNotAdditive1 version: 0.1 license: BSD3 cabal-version: >= 1.6 author: Stephen Blackheath stability: stable category: PackageTests build-type: Simple description: If you specify 'base' in the global build dependencies, then define an executable without base, it fails to find 'base' for the executable --------------------------------------- build-depends: base Executable lemon main-is: lemon.hs build-depends: bytestring, old-time Cabal-1.22.5.0/tests/PackageTests/BuildDeps/GlobalBuildDepsNotAdditive2/lemon.hs0000644000000000000000000000021712627136221025403 0ustar0000000000000000import qualified Data.ByteString.Char8 as C import System.Time main = do getClockTime let text = "lemon" C.putStrLn $ C.pack text Cabal-1.22.5.0/tests/PackageTests/BuildDeps/InternalLibrary0/0000755000000000000000000000000012627136221021705 5ustar0000000000000000Cabal-1.22.5.0/tests/PackageTests/BuildDeps/InternalLibrary0/Check.hs0000644000000000000000000000134612627136220023261 0ustar0000000000000000module PackageTests.BuildDeps.InternalLibrary0.Check where import Control.Monad import Data.Version import PackageTests.PackageTester import System.FilePath import Test.HUnit suite :: Version -> FilePath -> Test suite cabalVersion ghcPath = TestCase $ do let spec = PackageSpec { directory = "PackageTests" "BuildDeps" "InternalLibrary0" , configOpts = [] , distPref = Nothing } result <- cabal_build spec ghcPath assertBuildFailed result when (cabalVersion >= Version [1, 7] []) $ do let sb = "library which is defined within the same package." -- In 1.7 it should tell you how to enable the desired behaviour. assertOutputContains sb result Cabal-1.22.5.0/tests/PackageTests/BuildDeps/InternalLibrary0/my.cabal0000644000000000000000000000115512627136221023320 0ustar0000000000000000name: InternalLibrary0 version: 0.1 license: BSD3 cabal-version: >= 1.6 author: Stephen Blackheath stability: stable category: PackageTests build-type: Simple description: Check that with 'cabal-version:' containing versions less than 1.7, we do *not* have the new behaviour to allow executables to refer to the library defined in the same module. --------------------------------------- Library exposed-modules: MyLibrary build-depends: base, bytestring, old-time Executable lemon main-is: lemon.hs hs-source-dirs: programs build-depends: base, bytestring, old-time, InternalLibrary0 Cabal-1.22.5.0/tests/PackageTests/BuildDeps/InternalLibrary0/MyLibrary.hs0000644000000000000000000000030312627136221024147 0ustar0000000000000000module MyLibrary where import qualified Data.ByteString.Char8 as C import System.Time myLibFunc :: IO () myLibFunc = do getClockTime let text = "myLibFunc" C.putStrLn $ C.pack text Cabal-1.22.5.0/tests/PackageTests/BuildDeps/InternalLibrary0/programs/0000755000000000000000000000000012627136221023537 5ustar0000000000000000Cabal-1.22.5.0/tests/PackageTests/BuildDeps/InternalLibrary0/programs/lemon.hs0000644000000000000000000000011612627136221025203 0ustar0000000000000000import System.Time import MyLibrary main = do getClockTime myLibFunc Cabal-1.22.5.0/tests/PackageTests/BuildDeps/InternalLibrary1/0000755000000000000000000000000012627136221021706 5ustar0000000000000000Cabal-1.22.5.0/tests/PackageTests/BuildDeps/InternalLibrary1/Check.hs0000644000000000000000000000070012627136220023253 0ustar0000000000000000module PackageTests.BuildDeps.InternalLibrary1.Check where import PackageTests.PackageTester import System.FilePath import Test.HUnit suite :: FilePath -> Test suite ghcPath = TestCase $ do let spec = PackageSpec { directory = "PackageTests" "BuildDeps" "InternalLibrary1" , configOpts = [] , distPref = Nothing } result <- cabal_build spec ghcPath assertBuildSucceeded result Cabal-1.22.5.0/tests/PackageTests/BuildDeps/InternalLibrary1/my.cabal0000644000000000000000000000105412627136221023317 0ustar0000000000000000name: InternalLibrary1 version: 0.1 license: BSD3 cabal-version: >= 1.7.1 author: Stephen Blackheath stability: stable category: PackageTests build-type: Simple description: Check for the new (in >= 1.7.1) ability to allow executables to refer to the library defined in the same module. --------------------------------------- Library exposed-modules: MyLibrary build-depends: base, bytestring, old-time Executable lemon main-is: lemon.hs hs-source-dirs: programs build-depends: base, bytestring, old-time, InternalLibrary1 Cabal-1.22.5.0/tests/PackageTests/BuildDeps/InternalLibrary1/MyLibrary.hs0000644000000000000000000000030312627136221024150 0ustar0000000000000000module MyLibrary where import qualified Data.ByteString.Char8 as C import System.Time myLibFunc :: IO () myLibFunc = do getClockTime let text = "myLibFunc" C.putStrLn $ C.pack text Cabal-1.22.5.0/tests/PackageTests/BuildDeps/InternalLibrary1/programs/0000755000000000000000000000000012627136221023540 5ustar0000000000000000Cabal-1.22.5.0/tests/PackageTests/BuildDeps/InternalLibrary1/programs/lemon.hs0000644000000000000000000000011612627136221025204 0ustar0000000000000000import System.Time import MyLibrary main = do getClockTime myLibFunc Cabal-1.22.5.0/tests/PackageTests/BuildDeps/InternalLibrary2/0000755000000000000000000000000012627136221021707 5ustar0000000000000000Cabal-1.22.5.0/tests/PackageTests/BuildDeps/InternalLibrary2/Check.hs0000644000000000000000000000225112627136220023257 0ustar0000000000000000module PackageTests.BuildDeps.InternalLibrary2.Check where import qualified Data.ByteString.Char8 as C import PackageTests.PackageTester import System.FilePath import Test.HUnit suite :: FilePath -> FilePath -> Test suite ghcPath ghcPkgPath = TestCase $ do let spec = PackageSpec { directory = "PackageTests" "BuildDeps" "InternalLibrary2" , configOpts = [] , distPref = Nothing } let specTI = PackageSpec { directory = directory spec "to-install" , configOpts = [] , distPref = Nothing } unregister "InternalLibrary2" ghcPkgPath iResult <- cabal_install specTI ghcPath assertInstallSucceeded iResult bResult <- cabal_build spec ghcPath assertBuildSucceeded bResult unregister "InternalLibrary2" ghcPkgPath (_, _, output) <- run (Just $ directory spec) (directory spec "dist" "build" "lemon" "lemon") [] [] C.appendFile (directory spec "test-log.txt") (C.pack $ "\ndist/build/lemon/lemon\n"++output) assertEqual "executable should have linked with the internal library" "myLibFunc internal" (concat $ lines output) Cabal-1.22.5.0/tests/PackageTests/BuildDeps/InternalLibrary2/my.cabal0000644000000000000000000000106512627136221023322 0ustar0000000000000000name: InternalLibrary2 version: 0.1 license: BSD3 cabal-version: >= 1.7.1 author: Stephen Blackheath stability: stable category: PackageTests build-type: Simple description: This test is to make sure that the internal library is preferred by ghc to an installed one of the same name and version. --------------------------------------- Library exposed-modules: MyLibrary build-depends: base, bytestring, old-time Executable lemon main-is: lemon.hs hs-source-dirs: programs build-depends: base, bytestring, old-time, InternalLibrary2 Cabal-1.22.5.0/tests/PackageTests/BuildDeps/InternalLibrary2/MyLibrary.hs0000644000000000000000000000031412627136221024153 0ustar0000000000000000module MyLibrary where import qualified Data.ByteString.Char8 as C import System.Time myLibFunc :: IO () myLibFunc = do getClockTime let text = "myLibFunc internal" C.putStrLn $ C.pack text Cabal-1.22.5.0/tests/PackageTests/BuildDeps/InternalLibrary2/programs/0000755000000000000000000000000012627136221023541 5ustar0000000000000000Cabal-1.22.5.0/tests/PackageTests/BuildDeps/InternalLibrary2/programs/lemon.hs0000644000000000000000000000011612627136221025205 0ustar0000000000000000import System.Time import MyLibrary main = do getClockTime myLibFunc Cabal-1.22.5.0/tests/PackageTests/BuildDeps/InternalLibrary2/to-install/0000755000000000000000000000000012627136221023775 5ustar0000000000000000Cabal-1.22.5.0/tests/PackageTests/BuildDeps/InternalLibrary2/to-install/my.cabal0000644000000000000000000000065612627136221025415 0ustar0000000000000000name: InternalLibrary2 version: 0.1 license: BSD3 cabal-version: >= 1.6 author: Stephen Blackheath stability: stable category: PackageTests build-type: Simple description: This test is to make sure that the internal library is preferred by ghc to an installed one of the same name and version. --------------------------------------- Library exposed-modules: MyLibrary build-depends: base, bytestring, old-time Cabal-1.22.5.0/tests/PackageTests/BuildDeps/InternalLibrary2/to-install/MyLibrary.hs0000644000000000000000000000031512627136221026242 0ustar0000000000000000module MyLibrary where import qualified Data.ByteString.Char8 as C import System.Time myLibFunc :: IO () myLibFunc = do getClockTime let text = "myLibFunc installed" C.putStrLn $ C.pack text Cabal-1.22.5.0/tests/PackageTests/BuildDeps/InternalLibrary3/0000755000000000000000000000000012627136221021710 5ustar0000000000000000Cabal-1.22.5.0/tests/PackageTests/BuildDeps/InternalLibrary3/Check.hs0000644000000000000000000000225012627136220023257 0ustar0000000000000000module PackageTests.BuildDeps.InternalLibrary3.Check where import qualified Data.ByteString.Char8 as C import PackageTests.PackageTester import System.FilePath import Test.HUnit suite :: FilePath -> FilePath -> Test suite ghcPath ghcPkgPath = TestCase $ do let spec = PackageSpec { directory = "PackageTests" "BuildDeps" "InternalLibrary3" , configOpts = [] , distPref = Nothing } let specTI = PackageSpec { directory = directory spec "to-install" , configOpts = [] , distPref = Nothing } unregister "InternalLibrary3" ghcPkgPath iResult <- cabal_install specTI ghcPath assertInstallSucceeded iResult bResult <- cabal_build spec ghcPath assertBuildSucceeded bResult unregister "InternalLibrary3"ghcPkgPath (_, _, output) <- run (Just $ directory spec) (directory spec "dist" "build" "lemon" "lemon") [] [] C.appendFile (directory spec "test-log.txt") (C.pack $ "\ndist/build/lemon/lemon\n"++output) assertEqual "executable should have linked with the internal library" "myLibFunc internal" (concat $ lines output) Cabal-1.22.5.0/tests/PackageTests/BuildDeps/InternalLibrary3/my.cabal0000644000000000000000000000110012627136221023311 0ustar0000000000000000name: InternalLibrary3 version: 0.1 license: BSD3 cabal-version: >= 1.7.1 author: Stephen Blackheath stability: stable category: PackageTests build-type: Simple description: This test is to make sure that the internal library is preferred by ghc to an installed one of the same name, but a *newer* version. --------------------------------------- Library exposed-modules: MyLibrary build-depends: base, bytestring, old-time Executable lemon main-is: lemon.hs hs-source-dirs: programs build-depends: base, bytestring, old-time, InternalLibrary3 Cabal-1.22.5.0/tests/PackageTests/BuildDeps/InternalLibrary3/MyLibrary.hs0000644000000000000000000000031412627136221024154 0ustar0000000000000000module MyLibrary where import qualified Data.ByteString.Char8 as C import System.Time myLibFunc :: IO () myLibFunc = do getClockTime let text = "myLibFunc internal" C.putStrLn $ C.pack text Cabal-1.22.5.0/tests/PackageTests/BuildDeps/InternalLibrary3/programs/0000755000000000000000000000000012627136221023542 5ustar0000000000000000Cabal-1.22.5.0/tests/PackageTests/BuildDeps/InternalLibrary3/programs/lemon.hs0000644000000000000000000000011612627136221025206 0ustar0000000000000000import System.Time import MyLibrary main = do getClockTime myLibFunc Cabal-1.22.5.0/tests/PackageTests/BuildDeps/InternalLibrary3/to-install/0000755000000000000000000000000012627136221023776 5ustar0000000000000000Cabal-1.22.5.0/tests/PackageTests/BuildDeps/InternalLibrary3/to-install/my.cabal0000644000000000000000000000067012627136221025412 0ustar0000000000000000name: InternalLibrary3 version: 0.2 license: BSD3 cabal-version: >= 1.6 author: Stephen Blackheath stability: stable category: PackageTests build-type: Simple description: This test is to make sure that the internal library is preferred by ghc to an installed one of the same name but a *newer* version. --------------------------------------- Library exposed-modules: MyLibrary build-depends: base, bytestring, old-time Cabal-1.22.5.0/tests/PackageTests/BuildDeps/InternalLibrary3/to-install/MyLibrary.hs0000644000000000000000000000031512627136221026243 0ustar0000000000000000module MyLibrary where import qualified Data.ByteString.Char8 as C import System.Time myLibFunc :: IO () myLibFunc = do getClockTime let text = "myLibFunc installed" C.putStrLn $ C.pack text Cabal-1.22.5.0/tests/PackageTests/BuildDeps/InternalLibrary4/0000755000000000000000000000000012627136221021711 5ustar0000000000000000Cabal-1.22.5.0/tests/PackageTests/BuildDeps/InternalLibrary4/Check.hs0000644000000000000000000000225312627136220023263 0ustar0000000000000000module PackageTests.BuildDeps.InternalLibrary4.Check where import qualified Data.ByteString.Char8 as C import PackageTests.PackageTester import System.FilePath import Test.HUnit suite :: FilePath -> FilePath -> Test suite ghcPath ghcPkgPath = TestCase $ do let spec = PackageSpec { directory = "PackageTests" "BuildDeps" "InternalLibrary4" , configOpts = [] , distPref = Nothing } let specTI = PackageSpec { directory = directory spec "to-install" , configOpts = [] , distPref = Nothing } unregister "InternalLibrary4" ghcPkgPath iResult <- cabal_install specTI ghcPath assertInstallSucceeded iResult bResult <- cabal_build spec ghcPath assertBuildSucceeded bResult unregister "InternalLibrary4" ghcPkgPath (_, _, output) <- run (Just $ directory spec) (directory spec "dist" "build" "lemon" "lemon") [] [] C.appendFile (directory spec "test-log.txt") (C.pack $ "\ndist/build/lemon/lemon\n"++output) assertEqual "executable should have linked with the installed library" "myLibFunc installed" (concat $ lines output) Cabal-1.22.5.0/tests/PackageTests/BuildDeps/InternalLibrary4/my.cabal0000644000000000000000000000114112627136221023317 0ustar0000000000000000name: InternalLibrary4 version: 0.1 license: BSD3 cabal-version: >= 1.7.1 author: Stephen Blackheath stability: stable category: PackageTests build-type: Simple description: This test is to make sure that we can explicitly say we want InternalLibrary4-0.2 and it will give us the *installed* version 0.2 instead of the internal 0.1. --------------------------------------- Library exposed-modules: MyLibrary build-depends: base, bytestring, old-time Executable lemon main-is: lemon.hs hs-source-dirs: programs build-depends: base, bytestring, old-time, InternalLibrary4 >= 0.2 Cabal-1.22.5.0/tests/PackageTests/BuildDeps/InternalLibrary4/MyLibrary.hs0000644000000000000000000000031412627136221024155 0ustar0000000000000000module MyLibrary where import qualified Data.ByteString.Char8 as C import System.Time myLibFunc :: IO () myLibFunc = do getClockTime let text = "myLibFunc internal" C.putStrLn $ C.pack text Cabal-1.22.5.0/tests/PackageTests/BuildDeps/InternalLibrary4/programs/0000755000000000000000000000000012627136221023543 5ustar0000000000000000Cabal-1.22.5.0/tests/PackageTests/BuildDeps/InternalLibrary4/programs/lemon.hs0000644000000000000000000000011612627136221025207 0ustar0000000000000000import System.Time import MyLibrary main = do getClockTime myLibFunc Cabal-1.22.5.0/tests/PackageTests/BuildDeps/InternalLibrary4/to-install/0000755000000000000000000000000012627136221023777 5ustar0000000000000000Cabal-1.22.5.0/tests/PackageTests/BuildDeps/InternalLibrary4/to-install/my.cabal0000644000000000000000000000067012627136221025413 0ustar0000000000000000name: InternalLibrary4 version: 0.2 license: BSD3 cabal-version: >= 1.6 author: Stephen Blackheath stability: stable category: PackageTests build-type: Simple description: This test is to make sure that the internal library is preferred by ghc to an installed one of the same name but a *newer* version. --------------------------------------- Library exposed-modules: MyLibrary build-depends: base, bytestring, old-time Cabal-1.22.5.0/tests/PackageTests/BuildDeps/InternalLibrary4/to-install/MyLibrary.hs0000644000000000000000000000031512627136221026244 0ustar0000000000000000module MyLibrary where import qualified Data.ByteString.Char8 as C import System.Time myLibFunc :: IO () myLibFunc = do getClockTime let text = "myLibFunc installed" C.putStrLn $ C.pack text Cabal-1.22.5.0/tests/PackageTests/BuildDeps/SameDepsAllRound/0000755000000000000000000000000012627136221021666 5ustar0000000000000000Cabal-1.22.5.0/tests/PackageTests/BuildDeps/SameDepsAllRound/Check.hs0000644000000000000000000000124612627136220023241 0ustar0000000000000000module PackageTests.BuildDeps.SameDepsAllRound.Check where import Test.HUnit import PackageTests.PackageTester import System.FilePath import qualified Control.Exception as E suite :: FilePath -> Test suite ghcPath = TestCase $ do let spec = PackageSpec { directory = "PackageTests" "BuildDeps" "SameDepsAllRound" , configOpts = [] , distPref = Nothing } result <- cabal_build spec ghcPath do assertEqual "cabal build should succeed - see test-log.txt" True (successful result) `E.catch` \exc -> do putStrLn $ "Cabal result was "++show result E.throwIO (exc :: E.SomeException) Cabal-1.22.5.0/tests/PackageTests/BuildDeps/SameDepsAllRound/lemon.hs0000644000000000000000000000021712627136221023334 0ustar0000000000000000import qualified Data.ByteString.Char8 as C import System.Time main = do getClockTime let text = "lemon" C.putStrLn $ C.pack text Cabal-1.22.5.0/tests/PackageTests/BuildDeps/SameDepsAllRound/MyLibrary.hs0000644000000000000000000000030312627136221024130 0ustar0000000000000000module MyLibrary where import qualified Data.ByteString.Char8 as C import System.Time myLibFunc :: IO () myLibFunc = do getClockTime let text = "myLibFunc" C.putStrLn $ C.pack text Cabal-1.22.5.0/tests/PackageTests/BuildDeps/SameDepsAllRound/pineapple.hs0000644000000000000000000000022312627136221024174 0ustar0000000000000000import qualified Data.ByteString.Char8 as C import System.Time main = do getClockTime let text = "pineapple" C.putStrLn $ C.pack text Cabal-1.22.5.0/tests/PackageTests/BuildDeps/SameDepsAllRound/SameDepsAllRound.cabal0000644000000000000000000000150612627136221026016 0ustar0000000000000000name: SameDepsAllRound version: 0.1 license: BSD3 cabal-version: >= 1.6 author: Stephen Blackheath stability: stable synopsis: Same dependencies all round category: PackageTests build-type: Simple description: Check for the "old build-dep behaviour" namely that we get the same package dependencies on all build targets, even if different ones were specified for different targets . Here all .hs files use the three packages mentioned, so this shows that build-depends is not target-specific. This is the behaviour we want when cabal-version contains versions less than 1.7. --------------------------------------- Library exposed-modules: MyLibrary build-depends: base, bytestring Executable lemon main-is: lemon.hs build-depends: old-time Executable pineapple main-is: pineapple.hs Cabal-1.22.5.0/tests/PackageTests/BuildDeps/TargetSpecificDeps1/0000755000000000000000000000000012627136221022315 5ustar0000000000000000Cabal-1.22.5.0/tests/PackageTests/BuildDeps/TargetSpecificDeps1/Check.hs0000644000000000000000000000200112627136220023656 0ustar0000000000000000module PackageTests.BuildDeps.TargetSpecificDeps1.Check where import Test.HUnit import PackageTests.PackageTester import System.FilePath import Data.List import qualified Control.Exception as E import Text.Regex.Posix suite :: FilePath -> Test suite ghcPath = TestCase $ do let spec = PackageSpec { directory = "PackageTests" "BuildDeps" "TargetSpecificDeps1" , configOpts = [] , distPref = Nothing } result <- cabal_build spec ghcPath do assertEqual "cabal build should fail - see test-log.txt" False (successful result) assertBool "error should be in MyLibrary.hs" $ "MyLibrary.hs:" `isInfixOf` outputText result assertBool "error should be \"Could not find module `System.Time\"" $ (intercalate " " $ lines $ outputText result) =~ "Could not find module.*System.Time" `E.catch` \exc -> do putStrLn $ "Cabal result was "++show result E.throwIO (exc :: E.SomeException) Cabal-1.22.5.0/tests/PackageTests/BuildDeps/TargetSpecificDeps1/lemon.hs0000644000000000000000000000021712627136221023763 0ustar0000000000000000import qualified Data.ByteString.Char8 as C import System.Time main = do getClockTime let text = "lemon" C.putStrLn $ C.pack text Cabal-1.22.5.0/tests/PackageTests/BuildDeps/TargetSpecificDeps1/my.cabal0000644000000000000000000000075112627136221023731 0ustar0000000000000000name: TargetSpecificDeps1 version: 0.1 license: BSD3 cabal-version: >= 1.7.1 author: Stephen Blackheath stability: stable category: PackageTests build-type: Simple description: Check for the new build-dep behaviour, where build-depends are handled specifically for each target --------------------------------------- Library exposed-modules: MyLibrary build-depends: base, bytestring Executable lemon main-is: lemon.hs build-depends: base, bytestring, old-time Cabal-1.22.5.0/tests/PackageTests/BuildDeps/TargetSpecificDeps1/MyLibrary.hs0000644000000000000000000000030312627136221024557 0ustar0000000000000000module MyLibrary where import qualified Data.ByteString.Char8 as C import System.Time myLibFunc :: IO () myLibFunc = do getClockTime let text = "myLibFunc" C.putStrLn $ C.pack text Cabal-1.22.5.0/tests/PackageTests/BuildDeps/TargetSpecificDeps2/0000755000000000000000000000000012627136221022316 5ustar0000000000000000Cabal-1.22.5.0/tests/PackageTests/BuildDeps/TargetSpecificDeps2/Check.hs0000644000000000000000000000125412627136220023670 0ustar0000000000000000module PackageTests.BuildDeps.TargetSpecificDeps2.Check where import Test.HUnit import PackageTests.PackageTester import System.FilePath import qualified Control.Exception as E suite :: FilePath -> Test suite ghcPath = TestCase $ do let spec = PackageSpec { directory = "PackageTests" "BuildDeps" "TargetSpecificDeps2" , configOpts = [] , distPref = Nothing } result <- cabal_build spec ghcPath do assertEqual "cabal build should succeed - see test-log.txt" True (successful result) `E.catch` \exc -> do putStrLn $ "Cabal result was "++show result E.throwIO (exc :: E.SomeException) Cabal-1.22.5.0/tests/PackageTests/BuildDeps/TargetSpecificDeps2/lemon.hs0000644000000000000000000000015312627136221023763 0ustar0000000000000000import qualified Data.ByteString.Char8 as C main = do let text = "lemon" C.putStrLn $ C.pack text Cabal-1.22.5.0/tests/PackageTests/BuildDeps/TargetSpecificDeps2/my.cabal0000644000000000000000000000110712627136221023726 0ustar0000000000000000name: TargetSpecificDeps1 version: 0.1 license: BSD3 cabal-version: >= 1.7.1 author: Stephen Blackheath stability: stable category: PackageTests build-type: Simple description: Check for the new build-dep behaviour, where build-depends are handled specifically for each target This one is a control against TargetSpecificDeps1 - it is correct and should succeed. --------------------------------------- Library exposed-modules: MyLibrary build-depends: base, bytestring, old-time Executable lemon main-is: lemon.hs build-depends: base, bytestring Cabal-1.22.5.0/tests/PackageTests/BuildDeps/TargetSpecificDeps2/MyLibrary.hs0000644000000000000000000000030312627136221024560 0ustar0000000000000000module MyLibrary where import qualified Data.ByteString.Char8 as C import System.Time myLibFunc :: IO () myLibFunc = do getClockTime let text = "myLibFunc" C.putStrLn $ C.pack text Cabal-1.22.5.0/tests/PackageTests/BuildDeps/TargetSpecificDeps3/0000755000000000000000000000000012627136221022317 5ustar0000000000000000Cabal-1.22.5.0/tests/PackageTests/BuildDeps/TargetSpecificDeps3/Check.hs0000644000000000000000000000177012627136221023675 0ustar0000000000000000module PackageTests.BuildDeps.TargetSpecificDeps3.Check where import Test.HUnit import PackageTests.PackageTester import System.FilePath import Data.List import qualified Control.Exception as E import Text.Regex.Posix suite :: FilePath -> Test suite ghcPath = TestCase $ do let spec = PackageSpec { directory = "PackageTests" "BuildDeps" "TargetSpecificDeps3" , configOpts = [] , distPref = Nothing } result <- cabal_build spec ghcPath do assertEqual "cabal build should fail - see test-log.txt" False (successful result) assertBool "error should be in lemon.hs" $ "lemon.hs:" `isInfixOf` outputText result assertBool "error should be \"Could not find module `System.Time\"" $ (intercalate " " $ lines $ outputText result) =~ "Could not find module.*System.Time" `E.catch` \exc -> do putStrLn $ "Cabal result was "++show result E.throwIO (exc :: E.SomeException) Cabal-1.22.5.0/tests/PackageTests/BuildDeps/TargetSpecificDeps3/lemon.hs0000644000000000000000000000021712627136221023765 0ustar0000000000000000import qualified Data.ByteString.Char8 as C import System.Time main = do getClockTime let text = "lemon" C.putStrLn $ C.pack text Cabal-1.22.5.0/tests/PackageTests/BuildDeps/TargetSpecificDeps3/my.cabal0000644000000000000000000000073212627136221023732 0ustar0000000000000000name: test version: 0.1 license: BSD3 cabal-version: >= 1.7.1 author: Stephen Blackheath stability: stable category: PackageTests build-type: Simple description: Check for the new build-dep behaviour, where build-depends are handled specifically for each target --------------------------------------- Library exposed-modules: MyLibrary build-depends: base, bytestring, old-time Executable lemon main-is: lemon.hs build-depends: base, bytestring Cabal-1.22.5.0/tests/PackageTests/BuildDeps/TargetSpecificDeps3/MyLibrary.hs0000644000000000000000000000030312627136221024561 0ustar0000000000000000module MyLibrary where import qualified Data.ByteString.Char8 as C import System.Time myLibFunc :: IO () myLibFunc = do getClockTime let text = "myLibFunc" C.putStrLn $ C.pack text Cabal-1.22.5.0/tests/PackageTests/BuildTestSuiteDetailedV09/0000755000000000000000000000000012627136221021515 5ustar0000000000000000Cabal-1.22.5.0/tests/PackageTests/BuildTestSuiteDetailedV09/Check.hs0000644000000000000000000000120612627136221023065 0ustar0000000000000000module PackageTests.BuildTestSuiteDetailedV09.Check where import Test.HUnit import System.FilePath (()) import PackageTests.PackageTester suite :: PackageSpec -> FilePath -> Test suite inplaceSpec ghcPath = TestCase $ do let dir = "PackageTests" "BuildTestSuiteDetailedV09" spec = inplaceSpec { directory = dir , configOpts = "--enable-tests" : configOpts inplaceSpec } confResult <- cabal_configure spec ghcPath assertEqual "configure failed!" (successful confResult) True buildResult <- cabal_build spec ghcPath assertEqual "build failed!" (successful buildResult) True Cabal-1.22.5.0/tests/PackageTests/BuildTestSuiteDetailedV09/Dummy.hs0000644000000000000000000000013712627136221023145 0ustar0000000000000000module Dummy where import Distribution.TestSuite (Test) tests :: IO [Test] tests = return [] Cabal-1.22.5.0/tests/PackageTests/BuildTestSuiteDetailedV09/my.cabal0000644000000000000000000000060312627136221023125 0ustar0000000000000000name: BuildTestSuiteDetailedV09 version: 0.1 license: BSD3 author: Thomas Tuegel stability: stable category: PackageTests build-type: Simple description: Check that Cabal can build test suites of type detailed-0.9. Library exposed-modules: Dummy build-depends: base, Cabal test-suite test-Dummy type: detailed-0.9 test-module: Dummy build-depends: base, Cabal Cabal-1.22.5.0/tests/PackageTests/CMain/0000755000000000000000000000000012627136221015640 5ustar0000000000000000Cabal-1.22.5.0/tests/PackageTests/CMain/Bar.hs0000644000000000000000000000017412627136221016702 0ustar0000000000000000{-# LANGUAGE ForeignFunctionInterface #-} module Bar where bar :: IO () bar = return () foreign export ccall bar :: IO () Cabal-1.22.5.0/tests/PackageTests/CMain/Check.hs0000644000000000000000000000073312627136221017214 0ustar0000000000000000module PackageTests.CMain.Check ( checkBuild ) where import Test.HUnit import System.FilePath import PackageTests.PackageTester dir :: FilePath dir = "PackageTests" "CMain" checkBuild :: FilePath -> Test checkBuild ghcPath = TestCase $ do let spec = PackageSpec { directory = dir , distPref = Nothing , configOpts = [] } buildResult <- cabal_build spec ghcPath assertBuildSucceeded buildResult Cabal-1.22.5.0/tests/PackageTests/CMain/foo.c0000644000000000000000000000032412627136221016566 0ustar0000000000000000#include #include "HsFFI.h" #ifdef __GLASGOW_HASKELL__ #include "Bar_stub.h" #endif int main(int argc, char **argv) { hs_init(&argc, &argv); bar(); printf("Hello world!"); return 0; } Cabal-1.22.5.0/tests/PackageTests/CMain/my.cabal0000644000000000000000000000030112627136221017243 0ustar0000000000000000name: my version: 0.1 license: BSD3 cabal-version: >= 1.9.2 build-type: Simple executable foo main-is: foo.c other-modules: Bar build-depends: base Cabal-1.22.5.0/tests/PackageTests/CMain/Setup.hs0000644000000000000000000000005712627136221017276 0ustar0000000000000000import Distribution.Simple main = defaultMain Cabal-1.22.5.0/tests/PackageTests/DeterministicAr/0000755000000000000000000000000012627136221017737 5ustar0000000000000000Cabal-1.22.5.0/tests/PackageTests/DeterministicAr/Check.hs0000644000000000000000000001262612627136221021317 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} module PackageTests.DeterministicAr.Check where import Control.Monad import qualified Data.ByteString as BS import qualified Data.ByteString.Char8 as BS8 import Data.Char (isSpace) import Data.List #if __GLASGOW_HASKELL__ < 710 import Data.Traversable #endif import PackageTests.PackageTester import System.Exit import System.FilePath import System.IO import Test.HUnit (Assertion, Test (TestCase), assertFailure) import Distribution.Compiler (CompilerFlavor(..), CompilerId(..)) import Distribution.Package (packageKeyHash) import Distribution.Version (Version(..)) import Distribution.Simple.Compiler (compilerId) import Distribution.Simple.Configure (getPersistBuildConfig) import Distribution.Simple.LocalBuildInfo (LocalBuildInfo, compiler, pkgKey) -- Perhaps these should live in PackageTester. -- For a polymorphic @IO a@ rather than @Assertion = IO ()@. assertFailure' :: String -> IO a assertFailure' msg = assertFailure msg >> return {-unpossible!-}undefined ghcPkg_field :: String -> String -> FilePath -> IO [FilePath] ghcPkg_field libraryName fieldName ghcPkgPath = do (cmd, exitCode, raw) <- run Nothing ghcPkgPath [] ["--user", "field", libraryName, fieldName] let output = filter ('\r' /=) raw -- Windows -- copypasta of PackageTester.requireSuccess unless (exitCode == ExitSuccess) . assertFailure $ "Command " ++ cmd ++ " failed.\n" ++ "output: " ++ output let prefix = fieldName ++ ": " case traverse (stripPrefix prefix) (lines output) of Nothing -> assertFailure' $ "Command " ++ cmd ++ " failed: expected " ++ show prefix ++ " prefix on every line.\noutput: " ++ output Just fields -> return fields ghcPkg_field1 :: String -> String -> FilePath -> IO FilePath ghcPkg_field1 libraryName fieldName ghcPkgPath = do fields <- ghcPkg_field libraryName fieldName ghcPkgPath case fields of [field] -> return field _ -> assertFailure' $ "Command ghc-pkg field failed: " ++ "output not a single line.\noutput: " ++ show fields ------------------------------------------------------------------------ this :: String this = "DeterministicAr" suite :: FilePath -> FilePath -> Test suite ghcPath ghcPkgPath = TestCase $ do let dir = "PackageTests" this let spec = PackageSpec { directory = dir , configOpts = [] , distPref = Nothing } unregister this ghcPkgPath iResult <- cabal_install spec ghcPath assertInstallSucceeded iResult let distBuild = dir "dist" "build" libdir <- ghcPkg_field1 this "library-dirs" ghcPkgPath lbi <- getPersistBuildConfig (dir "dist") mapM_ (checkMetadata lbi) [distBuild, libdir] unregister this ghcPkgPath -- Almost a copypasta of Distribution.Simple.Program.Ar.wipeMetadata checkMetadata :: LocalBuildInfo -> FilePath -> Assertion checkMetadata lbi dir = withBinaryFile path ReadMode $ \ h -> do hFileSize h >>= checkArchive h where path = dir "libHS" ++ this ++ "-0" ++ (if ghc_7_10 then ("-" ++ packageKeyHash (pkgKey lbi)) else "") ++ ".a" ghc_7_10 = case compilerId (compiler lbi) of CompilerId GHC version | version >= Version [7, 10] [] -> True _ -> False checkError msg = assertFailure' $ "PackageTests.DeterministicAr.checkMetadata: " ++ msg ++ " in " ++ path archLF = "!\x0a" -- global magic, 8 bytes x60LF = "\x60\x0a" -- header magic, 2 bytes metadata = BS.concat [ "0 " -- mtime, 12 bytes , "0 " -- UID, 6 bytes , "0 " -- GID, 6 bytes , "0644 " -- mode, 8 bytes ] headerSize = 60 -- http://en.wikipedia.org/wiki/Ar_(Unix)#File_format_details checkArchive :: Handle -> Integer -> IO () checkArchive h archiveSize = do global <- BS.hGet h (BS.length archLF) unless (global == archLF) $ checkError "Bad global header" checkHeader (toInteger $ BS.length archLF) where checkHeader :: Integer -> IO () checkHeader offset = case compare offset archiveSize of EQ -> return () GT -> checkError (atOffset "Archive truncated") LT -> do header <- BS.hGet h headerSize unless (BS.length header == headerSize) $ checkError (atOffset "Short header") let magic = BS.drop 58 header unless (magic == x60LF) . checkError . atOffset $ "Bad magic " ++ show magic ++ " in header" unless (metadata == BS.take 32 (BS.drop 16 header)) . checkError . atOffset $ "Metadata has changed" let size = BS.take 10 $ BS.drop 48 header objSize <- case reads (BS8.unpack size) of [(n, s)] | all isSpace s -> return n _ -> checkError (atOffset "Bad file size in header") let nextHeader = offset + toInteger headerSize + -- Odd objects are padded with an extra '\x0a' if odd objSize then objSize + 1 else objSize hSeek h AbsoluteSeek nextHeader checkHeader nextHeader where atOffset msg = msg ++ " at offset " ++ show offset Cabal-1.22.5.0/tests/PackageTests/DeterministicAr/Lib.hs0000644000000000000000000000006412627136221021001 0ustar0000000000000000module Lib where dummy :: IO () dummy = return () Cabal-1.22.5.0/tests/PackageTests/DeterministicAr/my.cabal0000644000000000000000000000055112627136221021351 0ustar0000000000000000name: DeterministicAr version: 0 license: BSD3 cabal-version: >= 1.9.1 author: Liyang HU stability: stable category: PackageTests build-type: Simple description: Ensure our GNU ar -D emulation (#1537) works as advertised: check that all metadata in the resulting .a archive match the default. Library exposed-modules: Lib build-depends: base Cabal-1.22.5.0/tests/PackageTests/EmptyLib/0000755000000000000000000000000012627136221016376 5ustar0000000000000000Cabal-1.22.5.0/tests/PackageTests/EmptyLib/Check.hs0000644000000000000000000000072012627136221017746 0ustar0000000000000000module PackageTests.EmptyLib.Check where import PackageTests.PackageTester import System.FilePath import Test.HUnit -- See https://github.com/haskell/cabal/issues/1241 emptyLib :: FilePath -> Test emptyLib ghcPath = TestCase $ do let spec = PackageSpec { directory = "PackageTests" "EmptyLib" "empty" , configOpts = [] , distPref = Nothing } result <- cabal_build spec ghcPath assertBuildSucceeded result Cabal-1.22.5.0/tests/PackageTests/EmptyLib/empty/0000755000000000000000000000000012627136221017534 5ustar0000000000000000Cabal-1.22.5.0/tests/PackageTests/EmptyLib/empty/empty.cabal0000644000000000000000000000011612627136221021654 0ustar0000000000000000name: emptyLib Cabal-version: >= 1.2 version: 1.0 build-type: Simple Library Cabal-1.22.5.0/tests/PackageTests/Haddock/0000755000000000000000000000000012627136221016206 5ustar0000000000000000Cabal-1.22.5.0/tests/PackageTests/Haddock/Check.hs0000644000000000000000000000273412627136221017565 0ustar0000000000000000module PackageTests.Haddock.Check (suite) where import Control.Monad (unless, when) import Data.List (isInfixOf) import System.FilePath (()) import System.Directory (doesDirectoryExist, removeDirectoryRecursive) import Test.HUnit (Assertion, Test (TestCase), assertFailure) import Distribution.Simple.Utils (withFileContents) import PackageTests.PackageTester (PackageSpec(..), assertHaddockSucceeded, cabal_haddock) this :: String this = "Haddock" suite :: FilePath -> Test suite ghcPath = TestCase $ do let dir = "PackageTests" this haddocksDir = dir "dist" "doc" "html" "Haddock" spec = PackageSpec { directory = dir , configOpts = [] , distPref = Nothing } haddocksDirExists <- doesDirectoryExist haddocksDir when haddocksDirExists (removeDirectoryRecursive haddocksDir) hResult <- cabal_haddock spec [] ghcPath assertHaddockSucceeded hResult let docFiles = map (haddocksDir ) ["CPP.html", "Literate.html", "NoCPP.html", "Simple.html"] mapM_ (assertFindInFile "For hiding needles.") docFiles assertFindInFile :: String -> FilePath -> Assertion assertFindInFile needle path = withFileContents path (\contents -> unless (needle `isInfixOf` contents) (assertFailure ("expected: " ++ needle ++ "\n" ++ " in file: " ++ path))) Cabal-1.22.5.0/tests/PackageTests/Haddock/CPP.hs0000644000000000000000000000021212627136221017157 0ustar0000000000000000{-# LANGUAGE CPP #-} module CPP where #define HIDING hiding #define NEEDLES needles -- | For HIDING NEEDLES. data Haystack = Haystack Cabal-1.22.5.0/tests/PackageTests/Haddock/Literate.lhs0000644000000000000000000000011712627136221020466 0ustar0000000000000000> module Literate where > -- | For hiding needles. > data Haystack = Haystack Cabal-1.22.5.0/tests/PackageTests/Haddock/my.cabal0000644000000000000000000000047412627136221017624 0ustar0000000000000000name: Haddock version: 0.1 license: BSD3 author: Iain Nicol stability: stable category: PackageTests build-type: Simple Cabal-version: >= 1.2 description: Check that Cabal successfully invokes Haddock. Library exposed-modules: CPP, Literate, NoCPP, Simple other-extensions: CPP build-depends: base Cabal-1.22.5.0/tests/PackageTests/Haddock/NoCPP.hs0000644000000000000000000000026012627136221017457 0ustar0000000000000000module NoCPP (Haystack) where -- | For hiding needles. data Haystack = Haystack -- | Causes a build failure if the CPP language extension is enabled. stringGap = "Foo\ \Bar" Cabal-1.22.5.0/tests/PackageTests/Haddock/Simple.hs0000644000000000000000000000010712627136221017771 0ustar0000000000000000module Simple where -- | For hiding needles. data Haystack = Haystack Cabal-1.22.5.0/tests/PackageTests/OrderFlags/0000755000000000000000000000000012627136221016701 5ustar0000000000000000Cabal-1.22.5.0/tests/PackageTests/OrderFlags/Check.hs0000644000000000000000000000125512627136221020255 0ustar0000000000000000module PackageTests.OrderFlags.Check where import Test.HUnit import PackageTests.PackageTester import System.FilePath import Control.Exception #if !MIN_VERSION_base(4,6,0) import Prelude hiding (catch) #endif suite :: FilePath -> Test suite ghcPath = TestCase $ do let spec = PackageSpec { directory = "PackageTests" "OrderFlags" , configOpts = [] , distPref = Nothing } result <- cabal_build spec ghcPath do assertEqual "cabal build should succeed - see test-log.txt" True (successful result) `catch` \exc -> do putStrLn $ "Cabal result was "++show result throwIO (exc :: SomeException) Cabal-1.22.5.0/tests/PackageTests/OrderFlags/Foo.hs0000644000000000000000000000012112627136221017752 0ustar0000000000000000module Foo where x :: IO Int x = return 5 f :: IO Int f = do x return 3 Cabal-1.22.5.0/tests/PackageTests/OrderFlags/my.cabal0000644000000000000000000000061712627136221020316 0ustar0000000000000000name: OrderFlags version: 0.1 license: BSD3 author: Oleksandr Manzyuk stability: stable category: PackageTests build-type: Simple cabal-version: >=1.9.2 description: Check that Cabal correctly orders flags that are passed to GHC. library exposed-modules: Foo build-depends: base ghc-options: -Wall -Werror if impl(ghc >= 6.12.1) ghc-options: -fno-warn-unused-do-bind Cabal-1.22.5.0/tests/PackageTests/PathsModule/0000755000000000000000000000000012627136220017075 5ustar0000000000000000Cabal-1.22.5.0/tests/PackageTests/PathsModule/Executable/0000755000000000000000000000000012627136221021157 5ustar0000000000000000Cabal-1.22.5.0/tests/PackageTests/PathsModule/Executable/Check.hs0000644000000000000000000000077012627136221022534 0ustar0000000000000000module PackageTests.PathsModule.Executable.Check (suite) where import PackageTests.PackageTester (PackageSpec(..), assertBuildSucceeded, cabal_build) import System.FilePath import Test.HUnit suite :: FilePath -> Test suite ghcPath = TestCase $ do let spec = PackageSpec { directory = "PackageTests" "PathsModule" "Executable" , distPref = Nothing , configOpts = [] } result <- cabal_build spec ghcPath assertBuildSucceeded result Cabal-1.22.5.0/tests/PackageTests/PathsModule/Executable/Main.hs0000644000000000000000000000016212627136221022376 0ustar0000000000000000module Main where import Paths_PathsModule (getBinDir) main :: IO () main = do _ <- getBinDir return () Cabal-1.22.5.0/tests/PackageTests/PathsModule/Executable/my.cabal0000644000000000000000000000050412627136221022567 0ustar0000000000000000name: PathsModule version: 0.1 license: BSD3 author: Johan Tibell stability: stable category: PackageTests build-type: Simple Cabal-version: >= 1.2 description: Check that the generated paths module compiles. Executable TestPathsModule main-is: Main.hs other-modules: Paths_PathsModule build-depends: base Cabal-1.22.5.0/tests/PackageTests/PathsModule/Library/0000755000000000000000000000000012627136221020502 5ustar0000000000000000Cabal-1.22.5.0/tests/PackageTests/PathsModule/Library/Check.hs0000644000000000000000000000076212627136221022060 0ustar0000000000000000module PackageTests.PathsModule.Library.Check (suite) where import PackageTests.PackageTester (PackageSpec(..), assertBuildSucceeded, cabal_build) import System.FilePath import Test.HUnit suite :: FilePath -> Test suite ghcPath = TestCase $ do let spec = PackageSpec { directory = "PackageTests" "PathsModule" "Library" , distPref = Nothing , configOpts = [] } result <- cabal_build spec ghcPath assertBuildSucceeded result Cabal-1.22.5.0/tests/PackageTests/PathsModule/Library/my.cabal0000644000000000000000000000043612627136221022116 0ustar0000000000000000name: PathsModule version: 0.1 license: BSD3 author: Johan Tibell stability: stable category: PackageTests build-type: Simple Cabal-version: >= 1.2 description: Check that the generated paths module compiles. Library exposed-modules: Paths_PathsModule build-depends: base Cabal-1.22.5.0/tests/PackageTests/PreProcess/0000755000000000000000000000000012627136221016736 5ustar0000000000000000Cabal-1.22.5.0/tests/PackageTests/PreProcess/Check.hs0000644000000000000000000000100112627136221020277 0ustar0000000000000000module PackageTests.PreProcess.Check (suite) where import PackageTests.PackageTester (PackageSpec(..), assertBuildSucceeded, cabal_build) import System.FilePath import Test.HUnit suite :: FilePath -> Test suite ghcPath = TestCase $ do let spec = PackageSpec { directory = "PackageTests" "PreProcess" , distPref = Nothing , configOpts = ["--enable-tests", "--enable-benchmarks"] } result <- cabal_build spec ghcPath assertBuildSucceeded result Cabal-1.22.5.0/tests/PackageTests/PreProcess/Foo.hsc0000644000000000000000000000002112627136221020151 0ustar0000000000000000module Foo where Cabal-1.22.5.0/tests/PackageTests/PreProcess/Main.hs0000644000000000000000000000007612627136221020161 0ustar0000000000000000module Main where import Foo main :: IO () main = return () Cabal-1.22.5.0/tests/PackageTests/PreProcess/my.cabal0000644000000000000000000000112312627136221020344 0ustar0000000000000000name: PreProcess version: 0.1 license: BSD3 author: Johan Tibell stability: stable category: PackageTests build-type: Simple Cabal-version: >= 1.2 description: Check that preprocessors are run. Library exposed-modules: Foo build-depends: base Executable my-executable main-is: Main.hs other-modules: Foo build-depends: base Test-Suite my-test-suite main-is: Main.hs type: exitcode-stdio-1.0 other-modules: Foo build-depends: base Benchmark my-benchmark main-is: Main.hs type: exitcode-stdio-1.0 other-modules: Foo build-depends: base Cabal-1.22.5.0/tests/PackageTests/ReexportedModules/0000755000000000000000000000000012627136221020323 5ustar0000000000000000Cabal-1.22.5.0/tests/PackageTests/ReexportedModules/Check.hs0000644000000000000000000000230412627136221021673 0ustar0000000000000000module PackageTests.ReexportedModules.Check where import Data.Version import PackageTests.PackageTester import System.FilePath import Test.HUnit import Data.Maybe import Data.List import Control.Monad import Data.Char import Text.ParserCombinators.ReadP orFail :: String -> [(a, String)] -> a orFail err r = case find (all isSpace . snd) r of Nothing -> error err Just (i, _) -> i find' :: (a -> Bool) -> [a] -> Maybe a find' = find suite :: FilePath -> Test suite ghcPath = TestCase $ do -- ToDo: Turn this into a utility function (_, _, xs) <- run Nothing ghcPath [] ["--info"] let compat = (>= Version [7,9] []) . orFail "could not parse version" . readP_to_S parseVersion . snd . fromJust . find' ((=="Project version").fst) . orFail "could not parse ghc --info output" . reads $ xs when compat $ do let spec = PackageSpec { directory = "PackageTests" "ReexportedModules" , configOpts = [] , distPref = Nothing } result <- cabal_build spec ghcPath assertBuildSucceeded result Cabal-1.22.5.0/tests/PackageTests/ReexportedModules/ReexportedModules.cabal0000644000000000000000000000052012627136221024756 0ustar0000000000000000name: ReexportedModules version: 0.1.0.0 license-file: LICENSE author: Edward Z. Yang maintainer: ezyang@cs.stanford.edu build-type: Simple cabal-version: >=1.21 library build-depends: base, containers reexported-modules: containers:Data.Map as DataMap Cabal-1.22.5.0/tests/PackageTests/TemplateHaskell/0000755000000000000000000000000012627136221017730 5ustar0000000000000000Cabal-1.22.5.0/tests/PackageTests/TemplateHaskell/Check.hs0000644000000000000000000000243612627136221021306 0ustar0000000000000000module PackageTests.TemplateHaskell.Check where import PackageTests.PackageTester import System.FilePath import Test.HUnit vanilla :: FilePath -> Test vanilla ghcPath = TestCase $ do let spec = PackageSpec { directory = "PackageTests" "TemplateHaskell" "vanilla" , configOpts = [] , distPref = Nothing } result <- cabal_build spec ghcPath assertBuildSucceeded result profiling :: FilePath -> Test profiling ghcPath = TestCase $ do let flags = ["--enable-library-profiling" -- ,"--disable-library-vanilla" ,"--enable-profiling"] spec = PackageSpec { directory = "PackageTests" "TemplateHaskell" "profiling" , configOpts = flags , distPref = Nothing } result <- cabal_build spec ghcPath assertBuildSucceeded result dynamic :: FilePath -> Test dynamic ghcPath = TestCase $ do let flags = ["--enable-shared" -- ,"--disable-library-vanilla" ,"--enable-executable-dynamic"] spec = PackageSpec { directory = "PackageTests" "TemplateHaskell" "dynamic" , configOpts = flags , distPref = Nothing } result <- cabal_build spec ghcPath assertBuildSucceeded result Cabal-1.22.5.0/tests/PackageTests/TemplateHaskell/dynamic/0000755000000000000000000000000012627136221021354 5ustar0000000000000000Cabal-1.22.5.0/tests/PackageTests/TemplateHaskell/dynamic/Exe.hs0000644000000000000000000000012612627136221022430 0ustar0000000000000000{-# LANGUAGE TemplateHaskell #-} module Main where import TH main = print $(splice) Cabal-1.22.5.0/tests/PackageTests/TemplateHaskell/dynamic/Lib.hs0000644000000000000000000000011612627136221022414 0ustar0000000000000000{-# LANGUAGE TemplateHaskell #-} module Lib where import TH val = $(splice) Cabal-1.22.5.0/tests/PackageTests/TemplateHaskell/dynamic/my.cabal0000644000000000000000000000047512627136221022773 0ustar0000000000000000Name: templateHaskell Version: 0.1 Build-Type: Simple Cabal-Version: >= 1.2 Library Exposed-Modules: Lib Other-Modules: TH Build-Depends: base, template-haskell Extensions: TemplateHaskell Executable main Main-is: Exe.hs Build-Depends: base, template-haskell Extensions: TemplateHaskell Cabal-1.22.5.0/tests/PackageTests/TemplateHaskell/dynamic/TH.hs0000644000000000000000000000010412627136221022216 0ustar0000000000000000{-# LANGUAGE TemplateHaskell #-} module TH where splice = [| () |] Cabal-1.22.5.0/tests/PackageTests/TemplateHaskell/profiling/0000755000000000000000000000000012627136221021721 5ustar0000000000000000Cabal-1.22.5.0/tests/PackageTests/TemplateHaskell/profiling/Exe.hs0000644000000000000000000000012612627136221022775 0ustar0000000000000000{-# LANGUAGE TemplateHaskell #-} module Main where import TH main = print $(splice) Cabal-1.22.5.0/tests/PackageTests/TemplateHaskell/profiling/Lib.hs0000644000000000000000000000011612627136221022761 0ustar0000000000000000{-# LANGUAGE TemplateHaskell #-} module Lib where import TH val = $(splice) Cabal-1.22.5.0/tests/PackageTests/TemplateHaskell/profiling/my.cabal0000644000000000000000000000047512627136221023340 0ustar0000000000000000Name: templateHaskell Version: 0.1 Build-Type: Simple Cabal-Version: >= 1.2 Library Exposed-Modules: Lib Other-Modules: TH Build-Depends: base, template-haskell Extensions: TemplateHaskell Executable main Main-is: Exe.hs Build-Depends: base, template-haskell Extensions: TemplateHaskell Cabal-1.22.5.0/tests/PackageTests/TemplateHaskell/profiling/TH.hs0000644000000000000000000000010412627136221022563 0ustar0000000000000000{-# LANGUAGE TemplateHaskell #-} module TH where splice = [| () |] Cabal-1.22.5.0/tests/PackageTests/TemplateHaskell/vanilla/0000755000000000000000000000000012627136221021356 5ustar0000000000000000Cabal-1.22.5.0/tests/PackageTests/TemplateHaskell/vanilla/Exe.hs0000644000000000000000000000012612627136221022432 0ustar0000000000000000{-# LANGUAGE TemplateHaskell #-} module Main where import TH main = print $(splice) Cabal-1.22.5.0/tests/PackageTests/TemplateHaskell/vanilla/Lib.hs0000644000000000000000000000011612627136221022416 0ustar0000000000000000{-# LANGUAGE TemplateHaskell #-} module Lib where import TH val = $(splice) Cabal-1.22.5.0/tests/PackageTests/TemplateHaskell/vanilla/my.cabal0000644000000000000000000000047512627136221022775 0ustar0000000000000000Name: templateHaskell Version: 0.1 Build-Type: Simple Cabal-Version: >= 1.2 Library Exposed-Modules: Lib Other-Modules: TH Build-Depends: base, template-haskell Extensions: TemplateHaskell Executable main Main-is: Exe.hs Build-Depends: base, template-haskell Extensions: TemplateHaskell Cabal-1.22.5.0/tests/PackageTests/TemplateHaskell/vanilla/TH.hs0000644000000000000000000000010412627136221022220 0ustar0000000000000000{-# LANGUAGE TemplateHaskell #-} module TH where splice = [| () |] Cabal-1.22.5.0/tests/PackageTests/TestOptions/0000755000000000000000000000000012627136221017144 5ustar0000000000000000Cabal-1.22.5.0/tests/PackageTests/TestOptions/Check.hs0000644000000000000000000000204012627136221020511 0ustar0000000000000000module PackageTests.TestOptions.Check where import PackageTests.PackageTester import System.FilePath import Test.HUnit suite :: FilePath -> Test suite ghcPath = TestCase $ do let spec = PackageSpec { directory = "PackageTests" "TestOptions" , configOpts = ["--enable-tests"] , distPref = Nothing } _ <- cabal_build spec ghcPath result <- cabal_test spec [] ["--test-options=1 2 3"] ghcPath let message = "\"cabal test\" did not pass the correct options to the " ++ "test executable with \"--test-options\"" assertEqual message True $ successful result result' <- cabal_test spec [] [ "--test-option=1" , "--test-option=2" , "--test-option=3" ] ghcPath let message' = "\"cabal test\" did not pass the correct options to the " ++ "test executable with \"--test-option\"" assertEqual message' True $ successful result' Cabal-1.22.5.0/tests/PackageTests/TestOptions/test-TestOptions.hs0000644000000000000000000000041212627136221022745 0ustar0000000000000000module Main where import System.Environment ( getArgs ) import System.Exit ( exitFailure, exitSuccess ) main :: IO () main = do args <- getArgs if args == ["1", "2", "3"] then exitSuccess else putStrLn ("Got: " ++ show args) >> exitFailure Cabal-1.22.5.0/tests/PackageTests/TestOptions/TestOptions.cabal0000644000000000000000000000065012627136221022424 0ustar0000000000000000name: TestOptions version: 0.1 license: BSD3 author: Thomas Tuegel stability: stable category: PackageTests build-type: Simple cabal-version: >= 1.9.2 description: Check that Cabal passes the correct test options to test suites. executable dummy main-is: test-TestOptions.hs build-depends: base test-suite test-TestOptions main-is: test-TestOptions.hs type: exitcode-stdio-1.0 build-depends: base Cabal-1.22.5.0/tests/PackageTests/TestStanza/0000755000000000000000000000000012627136221016751 5ustar0000000000000000Cabal-1.22.5.0/tests/PackageTests/TestStanza/Check.hs0000644000000000000000000000450612627136221020327 0ustar0000000000000000module PackageTests.TestStanza.Check where import Test.HUnit import System.FilePath import qualified Data.Map as Map import PackageTests.PackageTester import Distribution.Version import Distribution.PackageDescription.Parse (readPackageDescription) import Distribution.PackageDescription.Configuration (finalizePackageDescription) import Distribution.Package (PackageName(..), Dependency(..)) import Distribution.PackageDescription ( PackageDescription(..), BuildInfo(..), TestSuite(..) , TestSuiteInterface(..), emptyBuildInfo, emptyTestSuite , defaultRenaming) import Distribution.Verbosity (silent) import Distribution.System (buildPlatform) import Distribution.Compiler ( CompilerId(..), CompilerFlavor(..), unknownCompilerInfo, AbiTag(..) ) import Distribution.Text suite :: FilePath -> Test suite ghcPath = TestCase $ do let dir = "PackageTests" "TestStanza" pdFile = dir "my" <.> "cabal" spec = PackageSpec { directory = dir , configOpts = [] , distPref = Nothing } result <- cabal_configure spec ghcPath assertOutputDoesNotContain "unknown section type" result genPD <- readPackageDescription silent pdFile let compiler = unknownCompilerInfo (CompilerId GHC $ Version [6, 12, 2] []) NoAbiTag anticipatedTestSuite = emptyTestSuite { testName = "dummy" , testInterface = TestSuiteExeV10 (Version [1,0] []) "dummy.hs" , testBuildInfo = emptyBuildInfo { targetBuildDepends = [ Dependency (PackageName "base") anyVersion ] , targetBuildRenaming = Map.singleton (PackageName "base") defaultRenaming , hsSourceDirs = ["."] } , testEnabled = False } case finalizePackageDescription [] (const True) buildPlatform compiler [] genPD of Left xs -> let depMessage = "should not have missing dependencies:\n" ++ (unlines $ map (show . disp) xs) in assertEqual depMessage True False Right (f, _) -> let gotTest = head $ testSuites f in assertEqual "parsed test-suite stanza does not match anticipated" gotTest anticipatedTestSuite Cabal-1.22.5.0/tests/PackageTests/TestStanza/my.cabal0000644000000000000000000000054712627136221020370 0ustar0000000000000000name: TestStanza version: 0.1 license: BSD3 author: Thomas Tuegel stability: stable category: PackageTests build-type: Simple description: Check that Cabal recognizes the Test stanza defined below. Library exposed-modules: MyLibrary build-depends: base test-suite dummy main-is: dummy.hs type: exitcode-stdio-1.0 build-depends: baseCabal-1.22.5.0/tests/PackageTests/TestSuiteExeV10/0000755000000000000000000000000012627136221017533 5ustar0000000000000000Cabal-1.22.5.0/tests/PackageTests/TestSuiteExeV10/Check.hs0000644000000000000000000001332512627136221021110 0ustar0000000000000000module PackageTests.TestSuiteExeV10.Check (checks) where import qualified Control.Exception as E (IOException, catch) import Control.Monad (when) import Data.Maybe (catMaybes) import System.Directory ( doesFileExist ) import System.FilePath import qualified Test.Framework as TF import Test.Framework (testGroup) import Test.Framework.Providers.HUnit (hUnitTestToTests) import Test.HUnit hiding ( path ) import Distribution.Compiler (CompilerFlavor(..), CompilerId(..)) import Distribution.PackageDescription (package) import Distribution.Simple.Compiler (compilerId) import Distribution.Simple.Configure (getPersistBuildConfig) import Distribution.Simple.LocalBuildInfo (compiler, localPkgDescr, pkgKey) import Distribution.Simple.Hpc import Distribution.Simple.Program.Builtin (hpcProgram) import Distribution.Simple.Program.Db ( emptyProgramDb, configureProgram, requireProgramVersion ) import Distribution.Text (display) import qualified Distribution.Verbosity as Verbosity import Distribution.Version (Version(..), orLaterVersion) import PackageTests.PackageTester checks :: FilePath -> [TF.Test] checks ghcPath = [ hunit "Test" $ checkTest ghcPath ] ++ hpcTestMatrix ghcPath ++ [ hunit "TestNoHpc/NoTix" $ checkTestNoHpcNoTix ghcPath , hunit "TestNoHpc/NoMarkup" $ checkTestNoHpcNoMarkup ghcPath ] hpcTestMatrix :: FilePath -> [TF.Test] hpcTestMatrix ghcPath = do libProf <- [True, False] exeProf <- [True, False] exeDyn <- [True, False] shared <- [True, False] let name = concat [ "WithHpc-" , if libProf then "LibProf" else "" , if exeProf then "ExeProf" else "" , if exeDyn then "ExeDyn" else "" , if shared then "Shared" else "" ] enable cond flag | cond = Just $ "--enable-" ++ flag | otherwise = Nothing opts = catMaybes [ enable libProf "library-profiling" , enable exeProf "profiling" , enable exeDyn "executable-dynamic" , enable shared "shared" ] return $ hunit name $ checkTestWithHpc ghcPath name opts dir :: FilePath dir = "PackageTests" "TestSuiteExeV10" checkTest :: FilePath -> Test checkTest ghcPath = TestCase $ buildAndTest ghcPath "Default" [] [] shouldExist :: FilePath -> Assertion shouldExist path = doesFileExist path >>= assertBool (path ++ " should exist") shouldNotExist :: FilePath -> Assertion shouldNotExist path = doesFileExist path >>= assertBool (path ++ " should exist") . not -- | Ensure that both .tix file and markup are generated if coverage is enabled. checkTestWithHpc :: FilePath -> String -> [String] -> Test checkTestWithHpc ghcPath name extraOpts = TestCase $ do isCorrectVersion <- correctHpcVersion when isCorrectVersion $ do let distPref' = dir "dist-" ++ name buildAndTest ghcPath name [] ("--enable-coverage" : extraOpts) lbi <- getPersistBuildConfig distPref' let way = guessWay lbi CompilerId comp version = compilerId (compiler lbi) subdir | comp == GHC && version >= Version [7, 10] [] = display (pkgKey lbi) | otherwise = display (package $ localPkgDescr lbi) mapM_ shouldExist [ mixDir distPref' way "my-0.1" subdir "Foo.mix" , mixDir distPref' way "test-Foo" "Main.mix" , tixFilePath distPref' way "test-Foo" , htmlDir distPref' way "test-Foo" "hpc_index.html" ] -- | Ensures that even if -fhpc is manually provided no .tix file is output. checkTestNoHpcNoTix :: FilePath -> Test checkTestNoHpcNoTix ghcPath = TestCase $ do buildAndTest ghcPath "NoHpcNoTix" [] [ "--ghc-option=-fhpc" , "--ghc-option=-hpcdir" , "--ghc-option=dist-NoHpcNoTix/hpc/vanilla" ] lbi <- getPersistBuildConfig (dir "dist-NoHpcNoTix") let way = guessWay lbi shouldNotExist $ tixFilePath (dir "dist-NoHpcNoTix") way "test-Foo" -- | Ensures that even if a .tix file happens to be left around -- markup isn't generated. checkTestNoHpcNoMarkup :: FilePath -> Test checkTestNoHpcNoMarkup ghcPath = TestCase $ do let tixFile = tixFilePath "dist-NoHpcNoMarkup" Vanilla "test-Foo" buildAndTest ghcPath "NoHpcNoMarkup" [("HPCTIXFILE", Just tixFile)] [ "--ghc-option=-fhpc" , "--ghc-option=-hpcdir" , "--ghc-option=dist-NoHpcNoMarkup/hpc/vanilla" ] shouldNotExist $ htmlDir (dir "dist-NoHpcNoMarkup") Vanilla "test-Foo" "hpc_index.html" -- | Build and test a package and ensure that both were successful. -- -- The flag "--enable-tests" is provided in addition to the given flags. buildAndTest :: FilePath -> String -> [(String, Maybe String)] -> [String] -> IO () buildAndTest ghcPath name envOverrides flags = do let spec = PackageSpec { directory = dir , distPref = Just $ "dist-" ++ name , configOpts = "--enable-tests" : flags } buildResult <- cabal_build spec ghcPath assertBuildSucceeded buildResult testResult <- cabal_test spec envOverrides [] ghcPath assertTestSucceeded testResult hunit :: TF.TestName -> Test -> TF.Test hunit name = testGroup name . hUnitTestToTests -- | Checks for a suitable HPC version for testing. correctHpcVersion :: IO Bool correctHpcVersion = do let programDb' = emptyProgramDb let verbosity = Verbosity.normal let verRange = orLaterVersion (Version [0,7] []) programDb <- configureProgram verbosity hpcProgram programDb' (requireProgramVersion verbosity hpcProgram verRange programDb >> return True) `catchIO` (\_ -> return False) where -- Distribution.Compat.Exception is hidden. catchIO :: IO a -> (E.IOException -> IO a) -> IO a catchIO = E.catch Cabal-1.22.5.0/tests/PackageTests/TestSuiteExeV10/Foo.hs0000644000000000000000000000007712627136221020616 0ustar0000000000000000module Foo where fooTest :: [String] -> Bool fooTest _ = True Cabal-1.22.5.0/tests/PackageTests/TestSuiteExeV10/my.cabal0000644000000000000000000000046412627136221021150 0ustar0000000000000000name: my version: 0.1 license: BSD3 cabal-version: >= 1.9.2 build-type: Simple library exposed-modules: Foo build-depends: base test-suite test-Foo type: exitcode-stdio-1.0 hs-source-dirs: tests main-is: test-Foo.hs build-depends: base, my Cabal-1.22.5.0/tests/PackageTests/TestSuiteExeV10/tests/0000755000000000000000000000000012627136221020675 5ustar0000000000000000Cabal-1.22.5.0/tests/PackageTests/TestSuiteExeV10/tests/test-Foo.hs0000644000000000000000000000017712627136221022736 0ustar0000000000000000module Main where import Foo import System.Exit main :: IO () main | fooTest [] = exitSuccess | otherwise = exitFailure Cabal-1.22.5.0/tests/UnitTests/0000755000000000000000000000000012627136220014234 5ustar0000000000000000Cabal-1.22.5.0/tests/UnitTests/Distribution/0000755000000000000000000000000012627136220016713 5ustar0000000000000000Cabal-1.22.5.0/tests/UnitTests/Distribution/Compat/0000755000000000000000000000000012627136221020137 5ustar0000000000000000Cabal-1.22.5.0/tests/UnitTests/Distribution/Compat/CreatePipe.hs0000644000000000000000000000110412627136221022510 0ustar0000000000000000module UnitTests.Distribution.Compat.CreatePipe (tests) where import Distribution.Compat.CreatePipe import System.IO (hClose, hGetContents, hPutStr, hSetEncoding, localeEncoding) import Test.Framework import Test.Framework.Providers.HUnit import Test.HUnit hiding (Test) tests :: [Test] tests = [testCase "Locale Encoding" case_Locale_Encoding] case_Locale_Encoding :: Assertion case_Locale_Encoding = assert $ do let str = "\0252" (r, w) <- createPipe hSetEncoding w localeEncoding out <- hGetContents r hPutStr w str hClose w return $! out == str Cabal-1.22.5.0/tests/UnitTests/Distribution/Compat/ReadP.hs0000644000000000000000000001015012627136221021463 0ustar0000000000000000----------------------------------------------------------------------------- -- | -- Module : Distribution.Compat.ReadP -- Copyright : (c) The University of Glasgow 2002 -- License : BSD-style (see the file libraries/base/LICENSE) -- -- Maintainer : libraries@haskell.org -- Portability : portable -- -- This code was originally in Distribution.Compat.ReadP. Please see that file -- for provenance. The tests have been integrated into the test framework. -- Some properties cannot be tested, as they hold over arbitrary ReadP values, -- and we don't have a good Arbitrary instance (nor Show instance) for ReadP. -- module UnitTests.Distribution.Compat.ReadP ( tests -- * Properties -- $properties ) where import Data.List import Distribution.Compat.ReadP import Test.Framework import Test.Framework.Providers.QuickCheck2 tests :: [Test] tests = [ testProperty "Get Nil" prop_Get_Nil , testProperty "Get Cons" prop_Get_Cons , testProperty "Look" prop_Look , testProperty "Fail" prop_Fail , testProperty "Return" prop_Return --, testProperty "Bind" prop_Bind --, testProperty "Plus" prop_Plus --, testProperty "LeftPlus" prop_LeftPlus --, testProperty "Gather" prop_Gather , testProperty "String Yes" prop_String_Yes , testProperty "String Maybe" prop_String_Maybe , testProperty "Munch" (prop_Munch evenChar) , testProperty "Munch1" (prop_Munch1 evenChar) --, testProperty "Choice" prop_Choice --, testProperty "ReadS" prop_ReadS ] -- --------------------------------------------------------------------------- -- QuickCheck properties that hold for the combinators {- $properties The following are QuickCheck specifications of what the combinators do. These can be seen as formal specifications of the behavior of the combinators. We use bags to give semantics to the combinators. -} type Bag a = [a] -- Equality on bags does not care about the order of elements. (=~) :: Ord a => Bag a -> Bag a -> Bool xs =~ ys = sort xs == sort ys -- A special equality operator to avoid unresolved overloading -- when testing the properties. (=~.) :: Bag (Int,String) -> Bag (Int,String) -> Bool (=~.) = (=~) -- Here follow the properties: prop_Get_Nil :: Bool prop_Get_Nil = readP_to_S get [] =~ [] prop_Get_Cons :: Char -> [Char] -> Bool prop_Get_Cons c s = readP_to_S get (c:s) =~ [(c,s)] prop_Look :: String -> Bool prop_Look s = readP_to_S look s =~ [(s,s)] prop_Fail :: String -> Bool prop_Fail s = readP_to_S pfail s =~. [] prop_Return :: Int -> String -> Bool prop_Return x s = readP_to_S (return x) s =~. [(x,s)] {- prop_Bind p k s = readP_to_S (p >>= k) s =~. [ ys'' | (x,s') <- readP_to_S p s , ys'' <- readP_to_S (k (x::Int)) s' ] prop_Plus :: ReadP Int Int -> ReadP Int Int -> String -> Bool prop_Plus p q s = readP_to_S (p +++ q) s =~. (readP_to_S p s ++ readP_to_S q s) prop_LeftPlus :: ReadP Int Int -> ReadP Int Int -> String -> Bool prop_LeftPlus p q s = readP_to_S (p <++ q) s =~. (readP_to_S p s +<+ readP_to_S q s) where [] +<+ ys = ys xs +<+ _ = xs prop_Gather s = forAll readPWithoutReadS $ \p -> readP_to_S (gather p) s =~ [ ((pre,x::Int),s') | (x,s') <- readP_to_S p s , let pre = take (length s - length s') s ] -} prop_String_Yes :: String -> [Char] -> Bool prop_String_Yes this s = readP_to_S (string this) (this ++ s) =~ [(this,s)] prop_String_Maybe :: String -> String -> Bool prop_String_Maybe this s = readP_to_S (string this) s =~ [(this, drop (length this) s) | this `isPrefixOf` s] prop_Munch :: (Char -> Bool) -> String -> Bool prop_Munch p s = readP_to_S (munch p) s =~ [(takeWhile p s, dropWhile p s)] prop_Munch1 :: (Char -> Bool) -> String -> Bool prop_Munch1 p s = readP_to_S (munch1 p) s =~ [(res,s') | let (res,s') = (takeWhile p s, dropWhile p s), not (null res)] {- prop_Choice :: [ReadP Int Int] -> String -> Bool prop_Choice ps s = readP_to_S (choice ps) s =~. readP_to_S (foldr (+++) pfail ps) s prop_ReadS :: ReadS Int -> String -> Bool prop_ReadS r s = readP_to_S (readS_to_P r) s =~. r s -} evenChar :: Char -> Bool evenChar = even . fromEnum Cabal-1.22.5.0/tests/UnitTests/Distribution/Utils/0000755000000000000000000000000012627136221020014 5ustar0000000000000000Cabal-1.22.5.0/tests/UnitTests/Distribution/Utils/NubList.hs0000644000000000000000000000271612627136221021736 0ustar0000000000000000{-# LANGUAGE CPP #-} module UnitTests.Distribution.Utils.NubList ( tests ) where #if __GLASGOW_HASKELL__ < 710 import Data.Monoid #endif import Distribution.Utils.NubList import Test.Framework import Test.Framework.Providers.HUnit (testCase) import Test.Framework.Providers.QuickCheck2 import Test.HUnit (Assertion, assertBool) tests :: [Test] tests = [ testCase "Numlist retains ordering" testOrdering , testCase "Numlist removes duplicates" testDeDupe , testProperty "Monoid Numlist Identity" prop_Identity , testProperty "Monoid Numlist Associativity" prop_Associativity ] someIntList :: [Int] -- This list must not have duplicate entries. someIntList = [ 1, 3, 4, 2, 0, 7, 6, 5, 9, -1 ] testOrdering :: Assertion testOrdering = assertBool "Maintains element ordering:" $ fromNubList (toNubList someIntList) == someIntList testDeDupe :: Assertion testDeDupe = assertBool "De-duplicates a list:" $ fromNubList (toNubList (someIntList ++ someIntList)) == someIntList -- --------------------------------------------------------------------------- -- QuickCheck properties for NubList prop_Identity :: [Int] -> Bool prop_Identity xs = mempty `mappend` toNubList xs == toNubList xs `mappend` mempty prop_Associativity :: [Int] -> [Int] -> [Int] -> Bool prop_Associativity xs ys zs = (toNubList xs `mappend` toNubList ys) `mappend` toNubList zs == toNubList xs `mappend` (toNubList ys `mappend` toNubList zs)